Sub Test ()
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add (1)
For i = 1 To 5
objExcel.Cells(i, 1).Select
objExcel.Cells(i, 1) = 12
objExcel.ActiveCell.Offset(i, 1).Select
Next i
rs = objExcel.Cells(Rows.Count, 1).End(xlUp).Row
objExcel.Quit
Set objExcel = Nothing
End Sub

Sub Summ()
Dim ДК, ДК0, Сумма As Long
Dim ЖК, ЖК0 As String

ReDim Arr(0 To 3) As String
Arr(0) = "500-1x2"
Arr(1) = "100-1x2"
Arr(2) = "200-7x2"
Arr(3) = "300-7x2"

For i = LBound(Arr) To UBound(Arr)
s = s + 1
If S = 1 Then
        ДК = Left(Arr(i), InStr(1, Arr(i), "-") - 1) 'получаем длину
        ЖК = Right(Arr(i), InStr(1, Arr(i), "-") - 1) 'получаем жильность
        Сумма = Сумма + ДК
Else
        ДК0 = Left(Arr(i), InStr(1, Arr(i), "-") - 1)
        ЖК0 = Right(Arr(i), InStr(1, Arr(i), "-") - 1)
            If ЖК0 = ЖК Then
            Сумма = Сумма + ДК0
            End If
End If
Next i
MsgBox "Сумма кабеля жильностью" & ЖК & " - " & Сумма
End Sub

Sub r()
Dim PathX, PDFname
On Error Resume Next
PathX = ActiveWorkbook.Path
SetXXX = CreateObject("Scripting.FileSystemObject")
PDFname = XXX.GetBaseName(ActiveWorkbook.Name)
ChDir PathX
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFname, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

Dim XL
Set XL = GetObject(, "Excel.Application" )
XL.ActiveSheet.ExportAsFixedFormat 0, , 0, True, False,,,True

With CreateObject("Scripting.FileSystemObject")
    For Each X In wscript.arguments
      .ExportAsFixedFormat 0, , 0, True, False,,,True
    Next
  End With

CreateObject("WScript.Network").UserName
CreateObject("WScript.Network").ComputerName
CreateObject("WScript.Network").UserDomain

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Const EM_GETLINECOUNT = 186
 
' Подсчет строк
Public Function Strok() As Long
Strok = UBound(Split(TextBox1.Text, vbNewLine)) + 1
End Function
 
' Подсчет символов
Public Function Simvols() As Long
Simvols = Len(TextBox1.Text)
End Function
 
Private Sub CommandButton1_Click()
Lin = SendMessage(TextBox1.hwnd, EM_GETLINECOUNT, 0&, 0&)
'Вывод происходит в Label:
Label1.Caption = "Кол-во строк:" & " " & Strok & " " & "Кол-во символов: " & Simvols & " " & "Кол-во линий: " & Lin
End Sub

Dim objWMIService, objProcess, colProcess
Dim strComputer, strProcessKill, strFilePath
strComputer = "."
strProcessKill = "'excel.exe'"
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = " & strProcessKill)
For Each objProcess In colProcess
     objProcess.Terminate
Next
Wscript.Quit

Sub SaveAndClose()
With Application
     .EnableEvents = False
     .DisplayAlerts = False
     Dim iBook As Workbook '
     For Each iBook In .Workbooks
         iBook.Save
     Next
     .Quit  
End With
End Sub

Sub Переименовать()

Dim FTR As Variant
Dim Filename As Variant

FTR = Application.GetOpenFilename()
Set FSO = CreateObject("Scripting.FileSystemObject")
Ext = "." & FSO.GetExtensionName(FTR) ' расширение файла
Filename = FSO.GetBaseName(FTR) ' имя файла без расширения
FilePath = FSO.GetParentFolderName(FTR) & "\" ' путь к папке в которой находится файл

Range("A1") = Filename
Range("A1").Activate

        Dim Txt As Variant
        Dim i As Integer
        Dim J As Integer
        Dim c As String
        Dim flag As Integer
        Dim outchr As String
        Dim outstr As String

         Dim Rus As Variant
         Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
         "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
         "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _
         "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
         "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я")

         Dim Eng As Variant
         Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _
         "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
         "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _
         "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _
         "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA")

         For Each Txt In ActiveCell
         outstr = Empty
         For i = 1 To Len(Txt)
         с = Mid(Txt, i, 1)

         flag = 0
         For J = 0 To 65
         If Rus(J) = с Then
         outchr = Eng(J)
         flag = 1
         Exit For
         End If
         Next J
         If flag Then outstr = outstr & outchr Else outstr = outstr & с
         Next i
         Txt.Value = outstr
         Next Txt

Filename = Range("A1")
X = FilePath & Filename & Ext
If Dir(FTR, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
Name FTR As X 'переименовываем файл
MsgBox "Файл переименован", vbInformation


End Sub

Sub Ext()

    Dim S As String
    Dim Ext As String
    Dim temp As Variant

    S = "."
    temp = InStrRev("D:\А.БВ.pdf", S, -1, vbTextCompare)
    Ext = Right("D:\А.БВ.pdf", temp)
    
End Sub

Option Explicit
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub ПОИСК()
Dim folder_ As String
With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        folder_ = .SelectedItems(1)
    End With
    folder_ = folder_ & IIf(Right(folder_, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders folder_
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Sub GetSubFolders(sPath)
 On Error Resume Next ' пропустить все ошибки
    Dim folder_$, file_$, s$
    Dim rw$
    Dim sh
    Dim c
     rw = 5
     Range("A5").Activate
    ActiveCell.EntireRow.Insert
    With Workbooks("Поиск.xlsm").Sheets(1)
        s = .Cells(2, 3).Value
    End With
    If s = "" Then
        MsgBox "Не заполненно поле поиска!"
        Exit Sub
    End If
    folder_ = sPath
    Dim sPathSeparator As String, sObjName As String
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
         file_ = Dir(folder_ & "*.xls*")
            DoEvents
            Workbooks.Open sPath & objFile.Name 'открываем книгу
                    With ActiveWorkbook
                        For Each sh In .Sheets
                            Set c = sh.Cells.Find(What:=s, After:=sh.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
                            If Not c Is Nothing Then
                                With Workbooks("Поиск.xlsm").Sheets(1)
                                    .Cells(rw, 1) = folder_ & ActiveWorkbook.Name
                                    .Hyperlinks.Add Anchor:=.Cells(rw, 1), Address:=folder_ & ActiveWorkbook.Name, SubAddress:=c.Address
                                End With
                                rw = rw + 1
                                Exit For
                            
                            End If
                        Next
                        .Close False
                    End With
                file_ = Dir
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
    
End Sub

objWrdDoc.Tables(1).Cell(i + 1, 3).Range.Text = Лист

objWrdApp.Activate
With objWrdDoc.Tables(1).Rows(2).Range
     .Font.Bold = 2
     .Font.Size = 12
     .ParagraphFormat.Alignment = 1
End With

Sub Содержание()

   Dim objWrdApp As Object, objWrdDoc As Object
   Set objWrdApp = CreateObject("Word.Application")
   objWrdApp.Visible = True
   Set objWrdDoc = objWrdApp.Documents.Open("L:\Шаблон.docx")
   
   objWrdDoc.Tables(1).Rows(1).Select
   With objWrdDoc.Tables(1).Rows(1)
         .Font.Size = 10
         .Font.Bold = wdToggle
         .ParagraphFormat.Alignment = wdAlignParagraphLeft
    End With
                    
    objWrdDoc.Close True
    'закрываем приложение Word
    objWrdApp.Quit
    'очищаем переменные Word - обязательно!
    Set objWrdDoc = Nothing: Set objWrdApp = Nothing

End Sub

Sub test()
     cherry
     Range("a1").Select
End Sub

Function cherry()
    If MsgBox("Тест", vbYesNo) = vbYes Then
        Else
        Exit Function
    End If
End Function