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)

Dim Sh_name as String
Sh_name= Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Text

Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, "B") = Mid(Cells(i, "A"), InStrRev(Cells(i, "A"), "/") + 1)
  Next
End Sub

Sub iKadastrNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim j As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "\d{10}:\d{2}:\d{3}:\d{4}"
  For i = 2 To 7
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
           j = 2
         For n = 0 To mo.Count - 1
           Cells(i, j) = mo(n)
           j = j + 1
         Next
    End If
   Next
 End With
End Sub

Function iKadastrNomer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{10}:\d{2}:\d{3}:\d{4}"
     iKadastrNomer = .Execute(cell)(0)
 End With
End Function

Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 4 To iLastRow
    Cells(i, "B") = Split(Cells(i, "A"), ",")(0) & "," & Split(Cells(i, "A"), ",")(1) & "," & Split(Cells(i, "A"), ",", 5)(4) & "," & Split(Cells(i, "A"), ",")(2) & "," & Split(Cells(i, "A"), ",")(3)
  Next
End Sub

Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 4 To iLastRow
        Cells(i, "B") = Split(Cells(i, "A"), ",", 4)(0) & "," & Split(Cells(i, "A"), ",", 4)(3) & "," & Split(Cells(i, "A"), ",", 4)(1) & "," & Split(Cells(i, "A"), ",", 4)(2)
  Next
End Sub

Sub Raznesti()
Dim Rng As Range
Dim iLastRow As Long
Dim iName As String
Dim pMain As Worksheet
Application.ScreenUpdating = False
  Set pMain = ThisWorkbook.Worksheets("pMain")
  iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    For Each Rng In Range("B3:E" & iLastRow).SpecialCells(xlCellTypeConstants, 2).Areas
     iName = Rng.Cells(0, 0)                          'очередной класс
       Workbooks.Add (xlWBATWorksheet)                'добавляем книгу с одним листом
        pMain.Range("A1:H1").Copy                     'копируем шапку таблицы
        Cells(1, 1).PasteSpecial xlPasteColumnWidths  'ширина столбцов в новой книге
        Cells(1, 1).PasteSpecial xlPasteValues        'вставляем шапку
        Rng.Copy Cells(2, 2)                          'копируем диапазон очеред.класса
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        ActiveWorkbook.Close SaveChanges:=True        'сохраняем книгу с именем класса
    Next
Application.ScreenUpdating = True
End Sub

Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, "B") = Cells(i, "F") & "," & Split(Cells(i, "A"), ",", 3)(2)
  Next
End Sub

Function Tip(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Тип:(.+)(?=\n)"
     If .Test(cell) Then
       Tip = WorksheetFunction.Trim(.Execute(cell)(0).SubMatches(0))
     Else
       Tip = "Нет типа"
     End If
 End With
End Function

Function Marka(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Торговая марка:(.+)(?=\n)"
     If .Test(cell) Then
       Marka = WorksheetFunction.Trim(.Execute(cell)(0).SubMatches(0))
     Else
       Marka = "Нет марки"
     End If
 End With
End Function

Function iText(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "z0[0-9a-z]{6}"
     If .test(cell) Then
      iText = UCase(.Execute(cell)(0))
     Else
       iText = "null"
     End If
 End With
End Function