=СУММПРОИЗВ((Лист2!B$1:B$999=B2)*(Лист2!A$1:A$999>=C2)*(Лист2!A$1:A$999<=D2))

Public Sub Fill()

Dim Str As String, D, D1, D2 As Date

For i = 2 To Worksheets("лист1").Cells(Rows.Count, 1).End(xlUp).Row
    Str = Worksheets("лист1").Cells(i, 5).Value
    For j = 1 To 100
        TZ = InStr(Str, ":")
        If TZ = 0 Then Exit For
        L = TZ + 2
        D1 = Worksheets("лист1").Cells(i, 3).Value
        D2 = Worksheets("лист1").Cells(i, 4).Value
        D = Left(Str, L)
        If (D >= D1) And (D <= D2) Then
            Counter = Counter + 1
            Worksheets("Лист3").Cells(Counter, 1).Value = Left(Str, L)
            Worksheets("Лист3").Cells(Counter, 2).Value = Worksheets("лист1").Cells(i, 2).Value
        End If
        If L = Len(Str) Then Exit For
        Str = Right(Str, Len(Str) - L - 1)
    Next j
Next i

End Sub

Function Daty(Baz_ As Range, ID_, d0_, d1_)
    d0_ = CDate(d0_)
    d1_ = CDate(d1_)
    Baz1_ = Baz_.Value
    For i = 1 To UBound(Baz1_)
        If Baz_(i, 2) = ID_ Then
            If CDate(Baz_(i, 1)) >= d0_ Then
                If CDate(Baz_(i, 1)) <= d1_ Then
                    t_ = t_ & vbLf & Baz_(i, 1)
                End If
            End If
        End If
    Next i
    Daty = Mid(t_, 2)
End Function