Макрос по сбору данных с дублями и поиск уникальных значений с подстановкой на новый лист

Option Explicit
 
Sub tt()
Dim a, i&, ii&, d1 As Object, d2 As Object, d3 As Object, dEx As Object, out, t$
Dim r As Range, shap As Range, Имя_подблока, k, kk
 
    Set d1 = CreateObject("Scripting.Dictionary") 'ID оценка
    Set d2 = CreateObject("Scripting.Dictionary") 'ID оценка+Имя подблока
    Set d3 = CreateObject("Scripting.Dictionary") 'Имя подблока
    
    Set dEx = CreateObject("Scripting.Dictionary") 'исключения
    dEx.Item("Справочник") = 0& 'можно загрузить список исключений любым смпособом
    
    Set r = Sheets("Выгрузка из Базы").Range("A1").CurrentRegion
    Set shap = r.Rows(1).Resize(, 12)
    
    a = r.Value
    For i = 2 To UBound(a)
        If Not dEx.exists(a(i, 14)) Then
        d3.Item(a(i, 17)) = 0& 'Имя подблока
            If Not d1.exists(a(i, 1)) Then d1.Item(a(i, 1)) = r.Rows(i).Cells(3).Resize(, 10)
            t = a(i, 1) & "|" & a(i, 17)
            If (a(i, 23)) = "true" Then d2.Item(t) = a(i, 22) Else d2.Item(t) = a(i, 19)
            t = a(i, 1) & "|" & a(1, 20)
            If Len(a(i, 20)) Then d2.Item(t) = a(i, 20)
            t = a(i, 1) & "|" & a(1, 21)
            If Len(a(i, 21)) Then d2.Item(t) = a(i, 21)
            t = a(i, 1) & "|" & a(1, 15) & "+" & a(i, 14)
            d2.Item(t) = a(i, 15)
            d3.Item(a(1, 15) & "+" & a(i, 14)) = 0&
        End If
    Next
    d3.Item(a(1, 20)) = 0&
    d3.Item(a(1, 21)) = 0&
 
    Application.ScreenUpdating = False
    
    With Workbooks.Add.Sheets(1)
    shap.Copy .Cells(1)
    Имя_подблока = d3.keys
    .Cells(13).Resize(, UBound(Имя_подблока) + 1) = Имя_подблока
        i = 1
        For Each k In d1.keys
        i = i + 1
        .Cells(i, 1) = k
        .Cells(i, 3).Resize(, 10) = d1.Item(k)
            For ii = 0 To UBound(Имя_подблока)
            .Cells(i, ii + 13) = d2.Item(k & "|" & Имя_подблока(ii))
            Next
        Next
        .Cells.EntireColumn.AutoFit
    End With
    
    Application.ScreenUpdating = True
End Sub

Имя_подблока = d3.keys