Sub iDel()
Dim i As Long
Dim iLastRow As Long
    iLastRow = Cells(Rows.Count, "L").End(xlUp).Row
  For i = 4 To iLastRow
    If InStr(1, Cells(i, "L"), "ИП ") > 0 Then
      Cells(i, "L").Replace Chr(34), ""
    End If
  Next
End Sub

Sub Макрос1()
' Макрос1 Макрос
    Range("B2:B23").Select
    Selection.Copy
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Shapes.Range(Array("Straight Arrow Connector 2")).Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

Function Get_AGA(cell As String) As Integer
Dim n As Integer
     n = InStr(1, cell, "AGA")
    If n > 0 Then
      Get_AGA = Get_AGA + 1
      Do
        n = InStr(n + 1, cell, "AGA")
        If n = 0 Then Exit Do
        Get_AGA = Get_AGA + 1
      Loop While n <> 0
    End If
End Function

Sub GetFragment()
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
Dim Kol_vo As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Kol_vo = 0
  For i = 1 To iLastRow
     n = InStr(1, Cells(i, 1), "AGA")
    If n > 0 Then
      Kol_vo = Kol_vo + 1
      Do
        n = InStr(n + 1, Cells(i, 1), "AGA")
        If n = 0 Then Exit Do
        Kol_vo = Kol_vo + 1
      Loop While n <> 0
    End If
  Next
    MsgBox "В столбце А ""AGA"" встречается: " & Kol_vo & " раз"
End Sub

Sub iProm()
Dim FilteredRng As Range
Dim i As Long
Dim iLastRow As Long
Dim iProm As String
Dim List1 As Worksheet
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
      iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
      Set List1 = ThisWorkbook.Worksheets("Лист1")
      Columns("M").ClearContents
    Range("D1:D" & iLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1"), Unique:=True
    iLastRow = Cells(Rows.Count, "M").End(xlUp).Row
      For i = 2 To iLastRow
        iProm = Cells(i, "M")
            If ActiveSheet.AutoFilterMode = False Then
                Range("A1:J1").AutoFilter
            Else
                If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
            End If
              Range("A1").AutoFilter Field:=4, Criteria1:=iProm
            With List1.AutoFilter.Range
               Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = iProm
                .Resize(.Rows.Count, 10).SpecialCells(xlCellTypeVisible).Copy Worksheets(iProm).Range("A1")
                Worksheets(iProm).Columns("A:J").AutoFit
                List1.Activate
                List1.ShowAllData
            End With
      Next
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Private Sub iSubTotal()
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:I" & iLastRow).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 7, 9), Replace:=True, _
     PageBreaks:=False, SummaryBelowData:=True
End Sub

Function iSum(cell As String)
Dim temp
Dim i As Integer
  temp = Split(cell, ";")
  For i = 0 To UBound(temp)
    iSum = iSum + CDbl(Split(temp(i), "-")(1))
  Next
End Function

Function GetArea(cell As String)
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = " общей площадью (\d+(,\d+)?)\s(?=га)"
    If .Test(cell) Then
      GetArea = CDbl(.Execute(cell)(0).SubMatches(0))
    End If
End With
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("E6:E7")) Is Nothing Then
     Application.EnableEvents = False
     ActiveSheet.UsedRange.Interior.ColorIndex = 2
    Range(Cells(12, 3), Cells(Range("E7") + 11, Range("E6") + 2)).Interior.ColorIndex = 1
  End If
    Application.EnableEvents = True
End Sub

Sub iFirstLast()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim iLastCol As Integer
 iLastCol = Cells(2, Columns.Count).End(xlToLeft).Column
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 Range("C3:D" & iLastRow).ClearContents
  For i = 3 To iLastRow
    For j = 5 To iLastCol
      If WorksheetFunction.CountA(Range(Cells(i, 5), Cells(i, iLastCol))) >= 2 Then   'есть первая м последняя выплата
        If Cells(i, j) <> "" Then
          Cells(i, "C") = Cells(2, j)   'первая выплата
          Do
            j = j + 1
            If Cells(i, j) <> "" Then Cells(i, "D") = Cells(2, j)
          Loop While j < iLastCol + 1
        End If
      Else      'одна выплата
        If Cells(i, j) <> "" Then
          Cells(i, "C") = Cells(2, j)   'первая выплата
        End If
      End If
    Next
  Next
End Sub

Function GetFragment(cell$)
   If InStr(1, cell, "/") > 0 Then
     GetFragment = Split(cell, "/", 2)(0)
   Else
     GetFragment = cell
   End If
End Function

Function AvtoNomer(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "[А-Я]{1,3}\s\d{3,4}\s([А-ЯA-Z]{1,3})?\s?(\d{2,3})?"
     .Global = True
   If .test(cell) Then
     AvtoNomer = .Execute(cell)(0)
   Else
     AvtoNomer = ""
   End If
 End With
End Function

Option Explicit
'активный лист Исходные данные
''Столбец С листа Даты использовал для признака объединенной ячейки
Sub iDate()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim iLastCol As Long
Dim BeginDate As Date
Dim EndDate As Date
Dim Dates As Worksheet
Dim iResult As String
Dim FoundCell As Range
Dim FoundPerechen As Range
Dim FAdr As String
Dim iNomer As Integer
Dim FoundBeginDate As Range
Dim k As Integer
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Set Dates = ThisWorkbook.Worksheets("Даты")
    With Dates
      iLR = .Cells(.Rows.Count, "B").End(xlUp).Row                'последняя строка листа Даты
      iLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column   'последний столбец листа Даты
      .Range("C2" & ":C" & iLR) = 0                               'Столбец С для признака объединенной ячейки
      .Range(.Cells(2, 4), .Cells(iLR, iLastCol)).ClearContents
    End With
  For i = 3 To iLastRow
    If Cells(i, "A") = "+" And Cells(i, "B").Interior.ColorIndex <> 2 Then
      BeginDate = Split(Cells(i, "E"), " ")(1)  'Начало
      EndDate = Split(Cells(i, "F"), " ")(1)    'Конец
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "([А-ЯЁ]+-?\d?)\s–\s([А-ЯЁ]+-?\d?)"
   If .test(Cells(i, "D")) Then                         'есть фраза с тире в столбце D
     iResult = .Execute(Cells(i, "D"))(0).submatches(0) 'нашли первое слово до тире
     Set FoundCell = Columns("I").Find(iResult, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         FAdr = FoundCell.Address           'адрес первого вхождения первого слова
         Do
             'есть ли в строке столбца I с найденным первым словом второе слово
           If InStr(1, Cells(FoundCell.Row, "I"), .Execute(Cells(i, "D"))(0).submatches(1)) > 0 Then
              iNomer = Cells(i, "B")
                'Cells(i, 1).Interior.ColorIndex = 6      'желтый
              Set FoundPerechen = Dates.Columns("B").Find(FoundCell, , xlValues, xlWhole)
              
              If Not FoundPerechen Is Nothing Then  'нашли Перечень из Исходные данные на листе Даты
                Set FoundBeginDate = Dates.Rows(1).Find(BeginDate, , xlFormulas, xlWhole)
                  'ячейка с FoundPerechen может быть объединенной
                k = 0
                If FoundPerechen.MergeCells Then
                  Do
                    Dates.Cells(FoundPerechen.Row + Dates.Cells(FoundPerechen.Row, "C"), FoundBeginDate.Column + k) = iNomer
                    k = k + 1
                  Loop While Dates.Cells(1, FoundBeginDate.Column + k) < EndDate + 1
                    Dates.Cells(FoundPerechen.Row, "C") = Dates.Cells(FoundPerechen.Row, "C") + 1
                Else
                  Do
                    Dates.Cells(FoundPerechen.Row, FoundBeginDate.Column + k) = iNomer
                    k = k + 1
                  Loop While Dates.Cells(1, FoundBeginDate.Column + k) < EndDate + 1
                End If
              End If
           End If
          If InStr(1, Cells(FoundCell.Row, "I"), .Execute(Cells(i, "D"))(0).submatches(1)) > 0 Then Exit Do    'нашли и первое и второе слово    
             Set FoundCell = Columns("I").Find(iResult, FoundCell, xlValues, xlPart)
         Loop While FoundCell.Address <> FAdr
       End If
   Else         'в столбце D ячейка не содержит фразу с тире
     iResult = Cells(i, "C")
     Set FoundCell = Columns("J").Find(iResult, , xlValues, xlWhole)
            If Not FoundCell Is Nothing Then
              If FoundCell.Offset(, 1) = Cells(i, 4) Then
               iNomer = Cells(i, "B")
              Set FoundPerechen = Dates.Columns("B").Find(FoundCell.Offset(, -1), , xlValues, xlWhole)
              If Not FoundPerechen Is Nothing Then  'нашли Перечень из Исходные данные на листе Даты
                Set FoundBeginDate = Dates.Rows(1).Find(BeginDate, , xlFormulas, xlWhole)
                  'ячейка с FoundPerechen может быть объединенной
                k = 0
                If FoundPerechen.MergeCells Then
                  Do
                    Dates.Cells(FoundPerechen.Row + Dates.Cells(FoundPerechen.Row, "C"), FoundBeginDate.Column + k) = iNomer
                    k = k + 1
                  Loop While Dates.Cells(1, FoundBeginDate.Column + k) < EndDate + 1
                    Dates.Cells(FoundPerechen.Row, "C") = Dates.Cells(FoundPerechen.Row, "C") + 1
                Else
                  Do
                    Dates.Cells(FoundPerechen.Row, FoundBeginDate.Column + k) = iNomer
                    k = k + 1
                  Loop While Dates.Cells(1, FoundBeginDate.Column + k) < EndDate + 1
                End If
              End If
                'Cells(i, 1).Interior.ColorIndex = 4    'зеленый
              End If
            End If
   End If
 End With
    End If
  Next
End Sub

Range("AA1:AA" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True

  Range("C2:R" & iLastRow).ClearContents

 Else
   Range("A" & j & ":U" & j).Delete
 End If
 Next
End Sub

For j = 2 To iLastRow

Sub PoiskFIO_Name()
Dim iLastRow As Long
Dim Found_Name As Range
Dim FAdr As String
Dim j As Integer
Dim n As Integer
   iLastRow = Cells(Rows.Count, "AA").End(xlUp).Row
   Range("B2:R" & iLastRow).ClearContents
 Range("AA1:AA" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
   iLastRow = Range("B1").End(xlDown).Row
 For j = 2 To iLastRow
 If Cells(j, "B") <> "BYE" Then
  n = 1
   Set Found_Name = Columns("AA").Find(Cells(j, "B"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
      Do
            If Found_Name.Offset(, 1) <> 0 Then
               Cells(j, 2 + n) = Found_Name.Offset(, 1)
               n = n + 1
            End If
            If Found_Name.Offset(, 2) <> 0 Then
               Cells(j, 2 + n) = Found_Name.Offset(, 2)
               n = n + 1
            End If
            If Found_Name.Offset(, 3) <> 0 Then
               Cells(j, 2 + n) = Found_Name.Offset(, 3)
               n = n + 1
            End If
           Set Found_Name = Columns("AA").FindNext(Found_Name)
      Loop While Found_Name.Address <> FAdr
    End If
   Range("S" & j) = WorksheetFunction.CountA(Range("C" & j & ":R" & j))
   Range("T" & j) = WorksheetFunction.Max(Range("C" & j & ":R" & j))
   Range("U" & j) = WorksheetFunction.Average(Range("C" & j & ":R" & j))
 End If
 Next
End Sub

Sub PoiskFIO_Name()
Dim iLastRow As Long
Dim Found_Name As Range
Dim FAdr As String
Dim j As Integer
Dim n As Integer
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("G1:Z" & iLastRow).ClearContents
 Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
   iLastRow = Range("G1").End(xlDown).Row
 For j = 2 To iLastRow
   n = 1
   Set Found_Name = Columns("A").Find(Cells(j, "G"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
      Do
            If Found_Name.Offset(, 1) <> 0 Then
               Cells(j, 7 + n) = Found_Name.Offset(, 1)
               n = n + 1
            End If
            If Found_Name.Offset(, 2) <> 0 Then
               Cells(j, 7 + n) = Found_Name.Offset(, 2)
               n = n + 1
            End If
            If Found_Name.Offset(, 3) <> 0 Then
               Cells(j, 7 + n) = Found_Name.Offset(, 3)
               n = n + 1
            End If
           Set Found_Name = Columns("A").FindNext(Found_Name)
      Loop While Found_Name.Address <> FAdr
    End If
 Next
End Sub

Sub Razr()
 Dim iHPBreak As HPageBreak
 Dim iRow As Long
 Dim HPB As Long
 Dim iHPB As Long
 Dim temp As String
  Cells(Rows.Count, 3).End(xlUp).Select 'последняя строка в документе
    With ActiveSheet.HPageBreaks            'коллекция горизонтальных разрывов страницы из области печати
      For iHPB = .Count To 1 Step -1                            ' HPageBreaks.Count - количество разрывов
        HPB = ActiveSheet.HPageBreaks(iHPB).Location.Row
        If .Item(iHPB).Type <> xlPageBreakManual Then           'тип разрыва, не ручной
          Do
            Cells(HPB, 2).EntireRow.Delete
            temp = Cells(HPB, 2)
          Loop While Not temp Like "Универсальный передаточный документ*"
        End If
      Next
   End With
End Sub