Sub Prepare()
    Dim Sh As Worksheet, Sh1 As Worksheet, out()
    Set Sh1 = ThisWorkbook.Worksheets("Свод")
    Sh1.Columns("D:D").NumberFormat = "m/d/yyyy"

    LastR = Sh1.Cells(Sh1.Rows.Count, "A").End(xlUp).Row
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name <> "Свод" Then
            LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
            dx = Sh.Range("A1:H" & LastRow)
            Шина = ""
            Модель_шины = dx(7, 8)
            For n = 24 To UBound(dx)
                If dx(n, 1) <> "" Then
                    Шина = dx(n, 1)
                End If

                If dx(n, 7) = "Модель шины" Then
                    Модель_шины = dx(n, 8)
                End If

                If dx(n, 3) <> "" Then
                    If IsDate(dx(n, 3)) Then
                        ReDim out(1 To 1, 1 To 5)
                        out(1, 1) = Sh.Name
                        out(1, 2) = Модель_шины
                        out(1, 3) = Шина
                        out(1, 4) = dx(n, 3)
                        out(1, 5) = dx(n, 7)
                        LastR = LastR + 1
                        Sh1.Cells(LastR, 1).Resize(1, 5) = out

                    End If
                End If
            Next

        End If
    Next
End Sub