Sub just_dic()
Dim sh As Worksheet, lc&, rng As Range, d As Object, k, a, arr, art$, coll, col$, c&, el&, i&, j&, head

With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With'создали словарь
Set d = CreateObject("Scripting.Dictionary")
d.comparemode = 1    'текстовое сравнение

For Each sh In ThisWorkbook.Sheets  'цикл по листам
With sh
If .Name <> "Лист1" Then    'лист, который не надо обрабатывать !!!

' лист "Summary"
If .Name = "Summary" Then
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    ' собираем шапку (должна быть заполнена!!)
    Set rng = sh.Range(.[c1], .Cells(1, lc))    '>>>>>>>>>>>>>>>>>>>!!!!!!!!!!
    ReDim arr(1 To rng.Cells.Count)
    For i = 1 To rng.Cells.Count
    arr(i) = Trim(rng.Cells(1, i).Value)
    Next i
    'массив шапки в строковую переменную записываем
    art$ = Join(arr, "|")
    art$ = "|" & art$ & "|"
    
Else
'любой др лист
    On Error Resume Next
    a = sh.UsedRange.Value    'массив листа
    col$ = ""
    'отбор нужных столбцов - цикл по столбцам массива листа
        For j = 2 To UBound(a, 2)   '>>>>>>>>>>>>>>>>>>>!!!!!!!!!!
            If InStr(art$, "|" & Trim(a(1, j)) & "|") <> 0 Then     'сверка с шапкой
                col$ = col$ & j & "|"
            End If
        Next j
        col$ = Left(col$, Len(col$) - 1)
        coll = Split(col$, "|")
        
     'цикл по строкам массива листа
        For i = 2 To UBound(a)
            k = Trim(a(i, 1)) & "|" & .Name '>>>>>>>>>>>>>>>>>>>!!!!!!!!!!
            'ключ из столбцов SITE ID, Project
                
            If Not d.exists(k) Then d.Add k     ' если нет в словаре, добавляем ключ
                    'собираем значения под ключ из нужных столбцов
                    For el = 0 To UBound(coll)
                      c = coll(el)
                            d.Item(k) = d.Item(k) & "|" & (a(i, c))
                    Next el
                    d.Item(k) = Right(d.Item(k), Len(d.Item(k)) - 1)
         Next i
    On Error GoTo 0
    
End If
End If
End With
Next sh

With ThisWorkbook.Sheets("Summary")
'запоминаем шапку
head = .[a1].Resize(1, .Cells(1, .Columns.Count).End(xlToLeft).Column).Value
'очищаем лист
.UsedRange.Cells.ClearContents
'выгрузка
.[a2].Resize(d.Count, 1) = Application.Transpose(Array(d.Keys))
.[a2].Resize(d.Count, 1).TextToColumns Destination:=Range("a2"), DataType:=xlDelimited, _
        Other:=True, OtherChar:="|"
.[c2].Resize(d.Count, 1) = Application.Transpose(Array(d.items))        '>>>>>>>>>>>>>>>>>>>!!!!!!!!!!
.[c2].Resize(d.Count, 1).TextToColumns Destination:=Range("c2"), DataType:=xlDelimited, _
        Other:=True, OtherChar:="|"
.[a1].Resize(1, UBound(head, 2)).Value = head
'автоподбор ширины столбцов
.[a1].CurrentRegion.Columns.AutoFit
End With
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
    
End Sub