Sub iArticul()
Dim i As Long
Dim j As Integer
Dim iLR As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLR = Cells(Rows.Count, "A").End(xlUp).Row
      Columns("B:B").Font.ColorIndex = 0
  For i = 1 To iLR
      Set re = CreateObject("VBScript.RegExp")
          re.Global = True
          re.IgnoreCase = True
          re.Pattern = Cells(i, "A")
        Set objMatches = re.Execute(Cells(i, "B"))
          If objMatches.Count <> 0 Then
             For j = 0 To objMatches.Count - 1
                Set objMatch = objMatches.Item(j)
                With Cells(i, "B").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                    .ColorIndex = 3
                End With
             Next
          End If
        Set re = Nothing
    Next
End Sub

Cells.AutoFilter _
Field:=1, _
Criteria1:="*Москва*"

Sub ПрописныеСтрочные()
Dim mo As Object
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "^[А-ЯЁ ]+"
     If .test(Cells(1, 1)) Then
       Set mo = .Execute(Cells(1, 1))
       Cells(1, 2) = mo(0)
       Cells(1, 3) = Mid(Cells(1, 1), mo(0).Length + 1)
    End If
 End With
End Sub

iLastRow =Cells(Rows.Count, "A").End(xlUp).Row
 Range("A2:A" &iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("C2"),Unique:=True

.Copy 
Sheets("Журнал проведения настройки").Range("a2").PasteSpecial xlPasteValues

Sub Перестановка()
Dim arr
   arr = Split(ActiveCell, " ", 2)
   ActiveCell = arr(1) & " " & arr(0)
End Sub

Sub FontSize()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    Cells(i, 16) = Cells(i, 2) & vbLf & "руб, 1 шт"
    Cells(i, 16).Font.Size = 27
    Cells(i, 16).Font.Bold = True
     With Cells(i, 16).Characters(Len(Cells(i, 2)) + 1, 10).Font
       .Size = 10
       .Bold = False
     End With
  Next
End Sub

Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  For i = 2 To iLastRow
    If Cells(i, 2).MergeCells Then
      n = Cells(i, 2).MergeArea.Count
      Range(Cells(i, 2), Cells(i + n - 1, 2)).UnMerge
      Cells(i, 2).Resize(n) = Cells(i, 2)
    End If
  Next
End Sub

ub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
Dim Zavod As Range
  iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  If iLastRow = 3 Then iLastRow = 4
  Range("C4:D" & iLastRow).Clear
    For Each Sht In Worksheets
      If Sht.Name <> "РЕЗУЛЬТАТ" Then
        With Sht
         Set Zavod = .Rows("11").Find("Завод", , xlValues, xlWhole)
          If Not Zavod Is Nothing Then
            iLR = .Cells(.Rows.Count, Zavod.Column).End(xlUp).Row
            iLastRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
            .Range(.Cells(12, Zavod.Column), .Cells(iLR, Zavod.Column)).Copy Cells(iLastRow, "C")
            Cells(iLastRow, "D").Resize(iLR - 11) = Sht.Name
          End If
        End With
      End If
    Next
End Sub

Sub DelAfterWsego()
Dim FoundWsego As Range
    Set FoundWsego = Columns("A").Find("Всего", , xlValues, xlWhole)
    If Not FoundWsego Is Nothing Then
      Rows(FoundWsego.Row + 1 & ":" & FoundWsego.Row + 10).Delete
    End If
    Range("A1").Select
End Sub

Sub Copy_Data()
Dim sh_src As Worksheet, sh_res As Worksheet
 Set sh_src = Workbooks("Book1.xlsm").Worksheets("Invoices")
Dim Sh_name As String
    Sh_name = Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Text
     Workbooks("Book2.xlsm").Activate
      If Not SheetExist(Sh_name) Then  'функция проверки наличия листа в файле
        sh_src.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sh_name
      End If
   MsgBox ("INCOICES DOWNLIADING - Complete!")
End Sub

     'функция проверки наличия листа в файле, лист есть - true
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function

iLastRow = Cells(Rows.Count, "F").End(xlUp).Row

sh_res.Cells(iLastRow,"F")

sh_res.[A1].End(xlDown)(2)