Sub DelSpace()
Dim FoundCell As Range
Dim i As Long
Dim iLastRow As Long
Dim re As Object
Dim temp0 As String
Dim temp1 As String
   iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
       Set re = CreateObject("VBScript.RegExp")
        re.Global = True
        re.Pattern = "\s+"
   For i = 17 To iLastRow
     If InStr(1, Cells(i, "D"), "OEM:") > 0 Then
       temp0 = Split(Cells(i, "D"), "OEM:")(0)
       temp1 = Split(Cells(i, "D"), "OEM:")(1)
        With re
            ActiveSheet.Cells(i, "E") = .Replace(temp0, " ") & "OEM: " & .Replace(temp1, "")
            ActiveSheet.Cells(i, "E") = Replace(ActiveSheet.Cells(i, "E"), ",", ", ")
        End With
     End If
   Next
End Sub

Sub iFindWord_Color()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim iResult As String
Dim FAdr As String
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Range("A2:A" & iLastRow).Interior.ColorIndex = 2
 For i = 2 To iLastRow
   With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "([А-ЯЁ]+-?\d?)\s-\s([А-ЯЁ]+-?\d?)"
   If .test(Cells(i, "C")) Then     'есть фраза с тире
     iResult = .Execute(Cells(i, "C"))(0).submatches(0) 'нашли первое слово до тире
     Set FoundCell = Columns("F").Find(iResult, , xlValues, xlPart)
       If Not FoundCell Is Nothing Then
         FAdr = FoundCell.Address
         Do
             'есть ли в строке столбца F с найденным первым словом второе слово
           If InStr(1, Cells(FoundCell.Row, "F"), .Execute(Cells(i, "C"))(0).submatches(1)) > 0 Then
              Cells(i, 1).Interior.ColorIndex = 6
               Exit Do
           End If
             Set FoundCell = Columns("F").FindNext(FoundCell)
         Loop While FoundCell.Address <> FAdr
       End If
   Else         'не содержит фразу с тире
     iResult = Cells(i, 2)
     Set FoundCell = Columns("F").Find(iResult, , xlValues, xlWhole)
            If Not FoundCell Is Nothing Then
              If FoundCell.Offset(, 1) = Cells(i, 3) Then
                Cells(i, 1).Interior.ColorIndex = 4
              End If
            End If
   End If
 End With
 Next
End Sub

Sub GetFragment()
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("B1:K" & iLastRow).ClearContents
 Range("B1:K" & iLastRow).NumberFormat = "###0"
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "[^,]+"
  For i = 1 To iLastRow
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        Cells(i, n + 2) = CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "source=([A-Z]+)(?=&)"
   If .test(cell) Then
     iResult = .Execute(cell)(0).SubMatches(0)
   Else
     iResult = cell
   End If
 End With
End Function

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

=ЕСЛИ(A1="11";B1;"-")

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
 For i = 2 To iLastRow
   Priznak = False
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