=ЕСЛИОШИБКА(ИНДЕКС(H2:H9;ЕСЛИОШИБКА(ПОИСКПОЗ($B13:$B25&C$12:DC$12;$B$2:$B$9&$D$2:$D$9;0);ЕСЛИОШИБКА(ПОИСКПОЗ($B13:$B25&C$12:DC$12;$F$2:$F$9&$E$2:$E$9;0);"")));"")&ЕСЛИОШИБКА(ИНДЕКС(ВЫБОР(ЕСЛИ($E$2:$E$9="";1;2);$I$2:$I$9;$H$2:$H$9);ЕСЛИОШИБКА(ПОИСКПОЗ($B13:$B25&C$12:DC$12;$B$2:$B$9&ВЫБОР(ЕСЛИ($E$2:$E$9="";1;2);$G$2:$G$9;$E$2:$E$9);0);ЕСЛИОШИБКА(ПОИСКПОЗ($B13:$B25&C$12:DC$12;$G$2:$G$9&$E$2:$E$9;0);"")));"")

Sub Макрос3()
    Dim arr1 As Variant, arr2 As Variant, rng As Range, n As Integer, i As Integer
    lr1 = Worksheets("Data").Cells(Rows.Count, 2).End(xlUp).Row
    arr1 = Worksheets("Data").Range(Worksheets("Data").Cells(2, 2), Worksheets("Data").Cells(lr1, 9))
    With Worksheets("Лист1")
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        lс2 = .Cells(2, Columns.Count).End(xlToLeft).Column
        arr2 = .Range(Worksheets("Лист1").Cells(3, 2), .Cells(lr2, lс2))
        .Range(Worksheets("Лист1").Cells(3, 3), .Cells(lr2, lс2)).Interior.Color = 16777215
        .Range(Worksheets("Лист1").Cells(3, 3), .Cells(lr2, lс2)) = ""
        For n = 1 To UBound(arr1)
            auto1 = arr1(n, 1)
            auto2 = arr1(n, 5)
            d1 = arr1(n, 3)
            d2 = arr1(n, 4)
            d3 = arr1(n, 6)
            pg = arr1(n, 7)
            rz = arr1(n, 8)
            For i = 1 To UBound(arr2)
                If arr2(i, 1) = auto1 Then
                    arr2(i, DatePart("y", CDate(d1)) + 1) = pg
                    If d2 = "" Then
                        arr2(i, DatePart("y", CDate(d3)) + 1) = rz
                        If rng Is Nothing Then Set rng = .Range(.Cells(i + 2, DatePart("y", CDate(d1)) + 2), .Cells(i + 2, DatePart("y", CDate(d3)) + 2)) Else Set rng = Union(rng, .Range(.Cells(i + 2, DatePart("y", CDate(d1)) + 2), .Cells(i + 2, DatePart("y", CDate(d3)) + 2)))
                    Else
                        arr2(i, DatePart("y", CDate(d2)) + 1) = pg
                        If rng Is Nothing Then Set rng = .Range(.Cells(i + 2, DatePart("y", CDate(d1)) + 2), .Cells(i + 2, DatePart("y", CDate(d2)) + 2)) Else Set rng = Union(rng, .Range(.Cells(i + 2, DatePart("y", CDate(d1)) + 2), .Cells(i + 2, DatePart("y", CDate(d2)) + 2)))
                    End If
                ElseIf arr2(i, 1) = auto2 Then
                    arr2(i, DatePart("y", CDate(d2)) + 1) = pg
                    arr2(i, DatePart("y", CDate(d3)) + 1) = rz
                    If rng Is Nothing Then Set rng = .Range(.Cells(i + 2, DatePart("y", CDate(d2)) + 2), .Cells(i + 2, DatePart("y", CDate(d3)) + 2)) Else Set rng = Union(rng, .Range(.Cells(i + 2, DatePart("y", CDate(d2)) + 2), .Cells(i + 2, DatePart("y", CDate(d3)) + 2)))
                End If
            Next
        Next
        .Range(.Cells(3, 2), .Cells(lr2, lс2)) = arr2
    End With
    If Not rng Is Nothing Then rng.Interior.Color = vbRed
End Sub