Sub iFindWord_Color()
Dim i As Long
Dim iLastRow As Long
Dim temp As String
Dim FoundCell As Range
Dim Priznak As Boolean
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Range("A2:A" & iLastRow).Interior.ColorIndex = 2
  Priznak = False
 For i = 2 To iLastRow
   If InStr(1, Cells(i, "C"), "-") > 1 And InStr(1, Cells(i, "C"), "тК ") > 1 Then
     temp = Split(Cells(i, "C"), "тК ")(1)
     Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         Cells(i, 1).Interior.ColorIndex = 6
       End If
   Else
    If InStr(1, Cells(i, "B"), "тК ") > 1 Then
     temp = Split(Cells(i, "B"), "тК ")(1)
          Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         Priznak = True
       End If
    End If
    If InStr(1, Cells(i, "C"), "тК ") > 1 Then
     temp = Split(Cells(i, "C"), "тК ")(1)
          Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         Priznak = True
       End If
     End If
        If Priznak Then Cells(i, 1).Interior.ColorIndex = 6
   End If
 Next
End Sub

Sub iFindWord_Color()
Dim i As Long
Dim iLastRow As Long
Dim temp As String
Dim FoundCell As Range
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Range("A2:A" & iLastRow).Interior.ColorIndex = 2
 For i = 2 To iLastRow
   If InStr(1, Cells(i, "C"), "-") > 1 And InStr(1, Cells(i, "C"), "тК ") > 1 Then
     temp = Split(Cells(i, "C"), "тК ")(1)
   Else
     temp = Split(Cells(i, "B"), "тК ")(1)
   End If
     Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         Cells(i, 1).Interior.ColorIndex = 6
       End If
 Next
End Sub

Sub iAreas()
Dim Rng_A As Range
Dim iLastRowA As Long
Dim Rng_D As Range
Dim iLastRowD As Long
Dim n As Integer
  iLastRowA = Cells(Rows.Count, "A").End(xlUp).Row
  iLastRowD = Cells(Rows.Count, "D").End(xlUp).Row
     
For Each Rng_D In Range("D2:D" & iLastRowD).SpecialCells(2, 1).Areas
  For Each Rng_A In Range("A2:A" & iLastRowA).SpecialCells(2, 1).Areas
    If Rng_D.Count = Rng_A.Count Then
      For n = 1 To Rng_D.Count
        If Rng_D(n, 1) = Rng_A(n, 1) Then
        Else
          Exit For
        End If
      Next
        If n = Rng_D.Count + 1 Then Rng_D(, 2) = Rng_A(, 2)
    End If
  Next
Next

макросом нахожу все нужные даты 

Function iSplit(cell$)
Dim mo As Object
Dim i As Integer
Dim n As Integer
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[А-ЯЁ][а-яё]+"
   If .test(cell) Then
   Set mo = .Execute(cell)
     For i = 0 To mo.Count - 1
       iSplit = iSplit & mo(i) & " "
       n = n + Len(mo(i))
     Next
       iSplit = iSplit & Mid(cell, n + 1, 6)
   Else
     iSplit = ""
   End If
 End With
End Function

Sub GetSum()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("F2:F" & iLastRow).ClearContents
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "\d+,\d+"
  For i = 2 To iLastRow
    If .Test(Cells(i, "E")) Then
      Set mo = .Execute(Cells(i, "E"))
      For n = 0 To mo.Count - 1
        Cells(i, "F") = Cells(i, "F") + CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub

Function toDate(str As String) As Date
Dim temp As String
    temp = Replace(str, "не позднее", "")
    toDate = CDate(Replace(temp, " г.", ""))
End Function

Sub FindLargeWord()     'для наибольшей длины слова в ячейке
Dim i As Long
Dim n As Long
Dim arr
Dim LargeWord As String
Dim temp As String
Dim FoundWord As Range
    Columns("A:B").Interior.ColorIndex = 2
  For i = 2 To 11
    arr = Split(Cells(i, "B"), " ")
      temp = arr(0)
    For n = 0 To UBound(arr)
      If Len(arr(n)) > Len(temp) Then
        LargeWord = arr(n)
        temp = LargeWord
      Else
        LargeWord = temp
      End If
    Next
      Set FoundWord = Columns(5).Find(LargeWord, , xlValues, xlPart)
      If Not FoundWord Is Nothing Then
        Range("A" & i & ":B" & i).Interior.ColorIndex = 6
      End If
  Next
End Sub

Sub FindArticul()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
Dim List1 As Worksheet
  Set List1 = ThisWorkbook.Worksheets("Лист1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B3:C" & iLastRow).ClearContents
 With List1
   For i = 3 To iLastRow
    Set cell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
    If Not cell Is Nothing Then
       Cells(i, "B") = cell.Offset(, 1)     'наименование
       Cells(i, "C") = cell.Offset(, 2)     'ячейка хранения
    Else
      MsgBox "На листе1 нет артикула: " & Cells(i, "A")
    End If
   Next
 End With
End Sub

Function iRU(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "//([A-Z\.]+)(?=/)"
   If .test(cell) Then
     iRU = .Execute(cell)(0).submatches(0)
   Else
     iRU = ""
   End If
 End With
End Function

Function iModel(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = ": ?([A-Z0-9]+)(?=,)"
   If .test(cell) Then
     iModel = .Execute(cell)(0).submatches(0)
   Else
     iModel = ""
   End If
 End With
End Function

Sub FindLastWord()
Dim i As Long
Dim arr
Dim LastWord As String
Dim FoundWord As Range
    Columns("A:B").Interior.ColorIndex = 2
  For i = 2 To 11
    arr = Split(Cells(i, "B"), " ")
      LastWord = arr(UBound(arr))
      Set FoundWord = Columns(5).Find(LastWord, , xlValues, xlPart)
      If Not FoundWord Is Nothing Then
        Range("A" & i & ":B" & i).Interior.ColorIndex = 6
      End If
  Next
End Sub

Sub iPoiskTown()
Dim j As Long
Dim k As Long
Dim n As Long
Dim FoundCell As Range
Dim arr
   arr = Array("Москва", "Петербург", "Адлер")
 For k = 1 To 3                           'цикл по столбцам
     For j = 0 To UBound(arr)             'цикл по городам
         Set FoundCell = Columns(k).Find(arr(j), , xlValues, xlWhole)
       If Not FoundCell Is Nothing Then
        n = n + 1                         'счетчик вхождений городов в столбец
       Else
         n = 0
         Exit For
       End If
     Next           'следующий город
     If n = UBound(arr) + 1 Then
        MsgBox "Все города находятся в " & Cells(1, k)
        Exit Sub
     End If
 Next               'следующий столбец
End Sub

iFoundRng.Offset(, 1).Resize(, k).Value = arrZam

iFoundRng.Offset(, 1).Resize(, k).Value = iFoundRng.Offset(, 1).Resize(, k).Value

Sub ConcatMonth()
Dim iBeginDate As Date
Dim iEndDate As Date
Dim j As Long
Dim jLastColumn As Long
  iBeginDate = Range("B3")
  If Day(iBeginDate) <> 1 Then
    MsgBox "В ячейке В3 не начальная дата месяца"
    Exit Sub
  End If
  jLastColumn = Cells(3, Columns.Count).End(xlToLeft).Column
    Rows("1:2").UnMerge
    Rows("1:2").ClearContents
    Rows("1:2").NumberFormat = "@"
    iEndDate = DateSerial(Year(iBeginDate), Month(iBeginDate) + 1, 1) - 1
  For j = 2 To jLastColumn
    Select Case Month(iEndDate)
      Case 1, 3, 5, 7, 8, 10, 12
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-31"
      Case 4, 6, 9, 11
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-30"
      Case 2
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          If Day(iEndDate) = 28 Then
            Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-28"
          Else
            Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-29"
          End If
    End Select
       Range(Cells(2, j), Cells(2, j + 9)).MergeCells = True
       Range(Cells(2, j), Cells(2, j + 9)) = "01-10"
       Range(Cells(2, j + 10), Cells(2, j + 19)).MergeCells = True
       Range(Cells(2, j + 10), Cells(2, j + 19)) = "11-20"
       Range(Cells(1, j), Cells(1, j + Day(iEndDate) - 1)).MergeCells = True
       Range(Cells(1, j), Cells(1, j + Day(iEndDate) - 1)) = Format(Cells(3, j), "MMMM YYYY")
        j = j + Day(iEndDate) - 1
        iEndDate = DateSerial(Year(iEndDate), Month(iEndDate) + 2, 1) - 1
  Next
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\((01|21)\)"
   If .test(cell) Then
     iResult = .Replace(cell, "$1")
   Else
     iResult = cell
   End If
 End With
End Function

Sub СКРЫТЬ()
    'Rows("2:19").Select
    'Selection.EntireRow.Hidden = True
    Range("B1:B19").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    'Range("A1").Select
End Sub
Sub ОТКРЫТЬ()
    'Rows("2:19").Select
    'Selection.EntireRow.Hidden = False
    'Range("A1").Select
    Range("B1:B19").EntireRow.Hidden = False
End Sub

Sub iBlocks()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Range("B2:B" & iLastRow).Font.ColorIndex = 1
  Range("B2:B" & iLastRow).Interior.ColorIndex = 2
  For Each Rng In Range("B2:B" & iLastRow).SpecialCells(2, 2).Areas
    For i = 1 To Rng.Count - 1
      If Rng.Cells(i) = Rng.Cells(i + 1) Then
      Else
        Exit For
      End If
    Next
      If i = Rng.Count Then
        Rng.Cells.Font.ColorIndex = 3
        Rng.Cells.Interior.ColorIndex = 6
      End If
  Next
End Sub

Sub Limits()
Dim FoundLimit As Range
Dim FirstAdr As String
Dim BeginDiapazon As Long
Dim EndDiapazon As Long
Dim iLastRow As Long
Dim iLastRow_1 As Long
Dim j As Integer
Dim limitNomer As Long
    With ThisWorkbook.Worksheets("Лист_1")
      iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("G2:M" & iLastRow).ClearContents        ' очищаем
            iLastRow_1 = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
    Set FoundLimit = .Columns("A").Find("Лимиты", , xlValues, xlWhole)
       If Not FoundLimit Is Nothing Then
             FirstAdr = FoundLimit.Address    'адрес первого вхождения
          Do
             limitNomer = FoundLimit.Offset(-1)
               BeginDiapazon = FoundLimit.Row + 1
             Set FoundLimit = .Columns("A").Find("Лимиты", After:=FoundLimit)
             If FoundLimit.Address <> FirstAdr Then
               EndDiapazon = FoundLimit.Row - 1
             Else
               EndDiapazon = iLastRow
             End If
        For j = BeginDiapazon To EndDiapazon    ' цикл по диапазону наименований
            If IsDate(Cells(j, 1)) Then
                .Cells(iLastRow_1, "G") = Int(.Cells(j, 1))   '
                .Cells(iLastRow_1, "H") = .Cells(j, 1) - Int(.Cells(j, 1))
                .Cells(iLastRow_1, "I") = .Cells(j, 2)
                .Cells(iLastRow_1, "J") = .Cells(j, 3)
                .Cells(iLastRow_1, "K") = .Cells(j, 4)
                .Cells(iLastRow_1, "L") = .Cells(j, 5) '
                .Cells(iLastRow_1, "M") = limitNomer                     '
                iLastRow_1 = iLastRow_1 + 1
            End If
        Next
          Loop While FoundLimit.Address <> FirstAdr
       End If
    End With
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+"
   If .test(cell) Then
     iResult = .Replace(cell, "")
   Else
     iResult = cell
   End If
 End With
End Function

Criteria1:= _
        "=" & Replace(CDbl(Range("A1")), ",", ".")

ActiveSheet.Range("A3:B14").AutoFilter Field:=2, Criteria1:="=" & CDbl(g1)

    ActiveSheet.Range("$A$2:$B$14").AutoFilter Field:=2, Criteria1:=Array( _
        "2025", "2026", "2027", "2028"), Operator:=xlFilterValues

Sub insertrow()
Dim tbl As ListObject
Dim n As Long
Dim k As Long
Dim i As Long
  Set tbl = ActiveSheet.ListObjects(1)
  For n = tbl.DataBodyRange.Rows.Count To 1 Step -1
    k = tbl.DataBodyRange(n, 5)
    For i = 1 To k - 1
      tbl.ListRows.Add (n + i)
      tbl.DataBodyRange(n + i, 1) = tbl.DataBodyRange(n, 1) + i
      tbl.DataBodyRange(n + i, 2) = tbl.DataBodyRange(n, 2)
      tbl.DataBodyRange(n + i, 3) = tbl.DataBodyRange(n, 3)
      tbl.DataBodyRange(n + i, 4) = tbl.DataBodyRange(n, 4) / k
      tbl.DataBodyRange(n + i, 4).NumberFormat = "#,###.00"
    Next
      tbl.DataBodyRange(n, 4) = tbl.DataBodyRange(n + 1, 4)
      tbl.DataBodyRange(n, 4).NumberFormat = "#,###.0"
  Next n

End Sub

Sub Sbor()
Dim FoundPart As Range
Dim WSH As Worksheet
Dim iLastRow As Long
Dim iLR As Long
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        If iLastRow <> 1 Then Range("A2:E" & iLastRow).ClearContents
    For Each WSH In Worksheets  'цикл по всем листам книги
        If WSH.Name <> "сборка" Then
With WSH
Set FoundPart = .Rows(1).Find("партия", , xlValues, xlWhole)
    If Not FoundPart Is Nothing Then
      iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
      iLR = .Cells(.Rows.Count, 2).End(xlUp).Row
      Cells(iLastRow, 1).Resize(iLR - 2) = .Name
      .Range("A3:B" & iLR).Copy Cells(iLastRow, 2)
      FoundPart.Offset(2).Resize(5, 2).Copy Cells(iLastRow, 4)
    End If
End With
        End If
    Next WSH
End Sub