Создание словаря

Sub InsertEmployees()
    'cd = Timer
    Dim sh_Employees As Worksheet
    Dim EmployeesListObj As ListObject
    Set sh_Employees = ThisWorkbook.Worksheets("OPR Ratings")
    Set EmployeesListObj = sh_Employees.ListObjects("Данные1")
 
    LastRowD = Sheets("OPR Ratings").Range("C" & Rows.Count).End(xlUp).Row
    Sheets("OPR Ratings").Range("B2:E" & LastRowD).ClearContents
 
    For Each Sh In Worksheets
        If Sh.Tab.Color = 15773696 Then
            With Sh
                LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                a = .Range("A3", "C" & LastRow).Value
                b = .Range("E3", "E" & LastRow).Value
                c = .Range("D3", "D" & LastRow).Value
                t = Sh.Name
                For i = 1 To UBound(a)
                    a(i, 2) = a(i, 1) & " " & a(i, 2) & " " & a(i, 3)
                    a(i, 1) = t
                Next
            End With
            Exit For
        End If
    Next
 
    Application.ScreenUpdating = False
    With EmployeesListObj.Range
        .Cells(2, 2).Resize(UBound(a), 2) = a
        .Cells(2, 4).Resize(UBound(a), 1) = b
        .Cells(2, 5).Resize(UBound(a), 1) = c
    End With
    Application.ScreenUpdating = True
 
    'Debug.Print Timer - cd
End Sub

Sub InsertEmployees()
'cd = Timer
    Dim sh_Employees As Worksheet
    Dim EmployeesListObj As ListObject
    Set sh_Employees = ThisWorkbook.Worksheets("OPR Ratings")
    Set EmployeesListObj = sh_Employees.ListObjects("Данные1")
    Dim t$, x&
 
    LastRowD = Sheets("OPR Ratings").Range("C" & Rows.Count).End(xlUp).Row
    Sheets("OPR Ratings").Range("B2:E" & LastRowD).ClearContents
 
    Application.ScreenUpdating = False
    x = 2
    For Each Sh In Worksheets
        If Sh.Tab.Color = 15773696 Then
            With Sh
                LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                a = .Range("A3", "C" & LastRow).Value
                b = .Range("E3", "E" & LastRow).Value
                c = .Range("D3", "D" & LastRow).Value
                t = Sh.Name
                For i = 1 To UBound(a)
                    a(i, 2) = a(i, 1) & " " & a(i, 2) & " " & a(i, 3)
                    a(i, 1) = t
                Next
            End With
            With EmployeesListObj.Range
                .Cells(x, 2).Resize(UBound(a), 2) = a
                .Cells(x, 4).Resize(UBound(a), 1) = b
                .Cells(x, 5).Resize(UBound(a), 1) = c
                x = x + UBound(a)
            End With
 
        End If
    Next
 
    Application.ScreenUpdating = True
 
    'Debug.Print Timer - cd
End Sub