Sub Svod()
Dim i As Long, j As Long, Rw As Long, Cl As Long
Dim a As String
Application.ScreenUpdating = False
With Sheets("Заявка")
Rw = .Cells(Rows.Count, 1).End(xlUp).Row
Cl = .Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 3 To Rw
        For j = 2 To Cl
            a = .Cells(1, j)
            .Cells(i, j) = Application.CountIf(Sheets(a).Range("D:D"), .Cells(i, 1).Value)
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub

Sub CollectDataFromAllSheets()
    Dim ws As Worksheet
     
    Set wbCurrent = ActiveWorkbook
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку табл из первого листа
    wbCurrent.Worksheets(1).Range("A3:D8").Copy Destination:=wbReport.Worksheets(1).Range("D3")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем и листе и листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон,который надо скопировать с каждого листа-любой вариант на выбор:
        Set rngData = ws.Range("A1:D5")            'фиксированный диапазон или
        Set rngData = ws.UsedRange                 'всё,что есть на листе или
        Set rngData = ws.Range("F5").CurrentRegion    'область,начиная от ячейки F5 или
        Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))    'от À2 и до конца листа
         
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
         
    Next ws
End Sub
         

Sub Svod()
Dim i As Long, j As Long, Rw As Long, Cl As Long
Dim a As String
Application.ScreenUpdating = False
With Sheets("Заявка")
Rw = .Cells(Rows.Count, 1).End(xlUp).Row - 1
Cl = .Cells(2, Columns.Count).End(xlToLeft).Column - 1
    'For i = 3 To Rw
        For j = 4 To Cl
            a = .Cells(2, j)
            Sheets(a).Range("D2:D" & Rw).Copy .Cells(3, j)
        Next
    'Next
End With
Application.ScreenUpdating = True
End Sub