Option Explicit
Private Sub zxzxzx()
Dim a&, b&, c&, d&, x, temp, arr(), dd, t!, dic As Object, COL As New Collection
Set dic = CreateObject("Scripting.Dictionary"): d = 500000: Randomize

For c = 10000 To d Step d / 10
  ReDim arr(1 To c)
  For a = 1 To c
    b = Rnd * c: arr(a) = b
    TextGen arr(a), 10, 10: b = Rnd * c: arr(a) = b
  Next a

'---UniList---
    t = Timer
    UniList arr(), dd
    Debug.Print "Array * " & c & " UniList Time: " & Format$(Timer - t, "0.00 sec")
  
'---Dictionary---
    t = Timer
        For Each x In arr
            temp = dic.Item(x)
        Next x
    Debug.Print "Array * " & c & " Dictionary Time: " & Format$(Timer - t, "0.00 sec")

'---Collection---
    t = Timer: On Error Resume Next
        For Each x In arr
            COL.Add x, CStr(x)
        Next x
    On Error GoTo 0: Debug.Print "Array * " & c & " Collection Time: " & Format$(Timer - t, "0.00 sec")
    dic.RemoveAll: Set COL = Nothing
Next c
End Sub

'----генератор стрингов----
Private Function TextGen(tt, ByVal ss%, ByVal LL%)
Dim aa As Byte, x%, t$, arr() As Byte, a As Byte, c%
ReDim arr(1 To 4, 1 To 2)
arr(1, 1) = 65: arr(1, 2) = 25: arr(2, 1) = 97: arr(2, 2) = 25
arr(3, 1) = 192: arr(3, 2) = 31: arr(4, 1) = 224: arr(4, 2) = 31
t = ""
If LL - ss > 0 Then c = ss + (Rnd * (LL - ss)) Else c = LL
For x = 1 To c
  a = Rnd * 4
  If a = 0 Then a = 1
  aa = arr(a, 1) + (Rnd * arr(a, 2))
  t = t & Chr(aa)
Next
tt = t
End Function
Private Sub UniList(arr(), dd, Optional S As Boolean = True)
Dim a&, b&, c&
If UBound(arr) + 1 - LBound(arr) + 1 > 1 Then
  If S Then QuickSort arr(), LBound(arr), UBound(arr)
  c = LBound(arr): b = 1
  For a = LBound(arr) + 1 To UBound(arr)
    If arr(a) > arr(c) Then b = b + 1: c = a
  Next
  If arr(a - 1) > arr(c) Then b = b + 1
Else: ReDim dd(1 To 1): dd(1) = arr(LBound(arr)): Exit Sub
End If
ReDim dd(1 To b): b = 1: c = LBound(arr): dd(b) = arr(c)
For a = LBound(arr) + 1 To UBound(arr)
  If arr(a) > arr(c) Then b = b + 1: c = a: dd(b) = arr(c)
Next
If arr(a - 1) > arr(c) Then b = b + 1: dd(b) = arr(a - 1)
End Sub
'------QSort--------
Private Sub QuickSort(a(), ByVal L&, ByVal U&)
Dim I&, J&, y, x
I = L: J = U: x = a((L + U) \ 2)
Do
  Do While a(I) < x: I = I + 1: Loop
  Do While x < a(J): J = J - 1: Loop 'a->c
  If I <= J Then
    y = a(I): a(I) = a(J): a(J) = y: I = I + 1: J = J - 1
  End If
Loop Until I > J
If L < J Then QuickSort a(), L, J
If I < U Then QuickSort a(), I, U
End Sub

Private Sub CommandButton3_Click()
    UsedRange.Offset(5).EntireRow.Delete ' удаляем ранее заполненные строки;
    Call CollectingSheets
End Sub

Private Sub Worksheet_Activate()
UsedRange.Offset(5).EntireRow.Delete ' удаляем ранее заполненные строки;
End Sub

Option Explicit

Sub CollectingSheets()
    Dim t, T1, T2, T3: t = Timer ' для подсчета времени работы
    Dim i&, j&, R&, C, Col&, Result(), UsAr(), ResAr(), PkAr()
    Dim IdDict As Object, USDict As Object, Head(), a
    Dim RN As Range, Cel As Range, Rn1 As Range, K&, L&
    Set IdDict = CreateObject("Scripting.Dictionary") ' словарь ID Отвтственных
    Set USDict = CreateObject("Scripting.Dictionary") ' словарь ID пользователей
'    Лист PC
    With Worksheets("PC")
'        последняя строка (по первому столбцу)
        R = .Cells(Rows.Count, 1).End(xlUp).Row
'        последний столбец( по первой строке)
        C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
'        Берем в массив данные
        PkAr = .Range("A2", .Cells(R, C)).Value
'        строка заголовков, ссылка
        Set RN = .Range(.Cells(1, 1), .Cells(1, C))
    End With
'    лист Sheet1, заголовки
    With Worksheets("Sheet1")
        Col = .Cells(5, Columns.Count).End(xlToLeft).Column 'количество столбцов в пятой стрке
'        ссылка на 5-ю строку
        Set Rn1 = .Range(.Cells(5, 1), .Cells(5, Col))
        With CreateObject("Scripting.Dictionary")
            For Each Cel In RN
'        создаем словарь - заголовки PC и в каких столбцах
                .Item(Cel.Value) = Cel.Column
            Next Cel
'            создаем массив соответствия заголовков Sheet1 и PC
            ReDim Head(1, 1 To Rn1.Count)
            For i = 1 To Rn1.Count
                If .exists(Rn1(i).Value) Then
                    Head(0, i) = i
                    Head(1, i) = .Item(Rn1(i).Value)
                Else
                    Head(0, i) = ""
                    Head(1, i) = ""
                End If
                    'Head(0, 12) = ""
                    'Head(1, 12) = ""
                    Head(0, 13) = ""
                    Head(1, 13) = ""
                    Head(0, 27) = ""
                    Head(1, 27) = ""
            Next i
        End With
    End With
    ReDim Result(1 To 300000, 1 To Col)
    With Worksheets("User")
        R = .Cells(Rows.Count, 1).End(xlUp).Row
        C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
        UsAr = .Range("A2", .Cells(R, C)).Value
'        словарь Container_Unique_Id User
        For i = 1 To UBound(UsAr)
            USDict(UsAr(i, 1)) = UsAr(i, 2)
        Next
    End With
    With Worksheets("User1")
        R = .Cells(Rows.Count, 1).End(xlUp).Row
        C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
        ResAr = .Range("A2", .Cells(R, C)).Value
        With IdDict
            For i = 1 To UBound(ResAr)
'        словарь Container_Unique_Id User1
                 If .exists(ResAr(i, 1)) Then
'                    если User1 несколько - собираем их в одну запись
                    .Item(ResAr(i, 1)) = .Item(ResAr(i, 1)) & "#" & ResAr(i, 2)
                 Else
                    .Item(ResAr(i, 1)) = ResAr(i, 2)
                 End If
            Next
        End With
   End With
   
   K = 0 ' № строки массива результата
'   сборка результата в моассив
   For i = 1 To UBound(PkAr)
        If IdDict.exists(PkAr(i, 1)) Then
            a = Split(IdDict(PkAr(i, 1)), "#")
            For L = 0 To UBound(a)
                K = K + 1
                For j = 1 To Col
                    If IsNumeric(Head(0, j)) Then
                        Result(K, j) = PkAr(i, Head(1, j))
                    End If
                Next j
                'Result(K, 12) = USDict(PkAr(i, 1))
                Result(K, 13) = USDict(PkAr(i, 1))
                Result(K, 27) = a(L)
           Next L
        Else
                K = K + 1
                For j = 1 To Col
                    If IsNumeric(Head(0, j)) Then
                        Result(K, j) = PkAr(i, Head(1, j))
                    End If
                Next j
        End If
   Next i
'    время обработки данных
    T1 = Timer
    T3 = T1 - t
MsgBox "Обработка данных - " & T3 & "cek" & Chr(10)
'    вывод на лист
Application.ScreenUpdating = False 'Выключаем обновление экрана'
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
   With Sheets("Sheet1")
        .Cells(6, 1).Resize(K, Col).Value = Result ' Вывод результирующего массива на лист
   End With
Application.ScreenUpdating = True 'Выключаем обновление экрана'
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
   T2 = Timer - T1
'   информация о времени работы.
   MsgBox "Вывод на лист - " & T2 & "cek" & Chr(10) & "всего - " & T3 + T2
End Sub

Option Explicit
'===========================================================================================================================
Sub t()
Dim r&, c&, valNum
    For c = 2 To 17                         ' цикл по столбцам
        r = Cells(5, c).Value2              ' номер строки находится в 5 строке текущего (в цикле) столбца
        valNum = Cells(7, c).Value2         ' значение — в 7 строке
        Cells(r, c).Value2 = valNum         ' проставляем значение в нужную ячейку с известными координатами
    Next c
End Sub
'===========================================================================================================================
Sub tt()
Dim arrRows, arrVal, c&

arrRows = [b5:q5].Value2    'номера строк забираем в массив
arrVal = [b7:q7].Value2     'значения для простановки забираем в массив

    For c = 2 To 17 ' цикл по стобцам (номера)
        Cells(arrRows(1, c-1), c).Value2 = arrVal(1, c-1)   ' проставляем в ячейку значение (получаем по аналогии со строками)
    Next c
End Sub
'===========================================================================================================================