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