Выгрузка значений словаря - VBA

Формулировка задачи:

Приветствую всех! Надеюсь на Вашу помощь с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе "Лист2". Писать построчно диапазон тоже не выходит, выгружает 1 строку значений Файл прилагается ниже.

                    Листинг программы
                
 
                        
                          
                    
Sub krivoy_code()
 
Dim A, B
Dim dic
Dim i As Integer, j As Integer
 
Set dic = CreateObject("Scripting.Dictionary")
 
A = Worksheets("источник").[a1].CurrentRegion.Value
For i = 2 To UBound(A)
    For j = 2 To UBound(A, 2)
        dic(A(i, 1) & A(1, j)) = A(i, j)
    Next j
Next i
 
With Worksheets(1)
    B = [a6].CurrentRegion.Value
    For i = 1 To UBound(B)
        For j = 1 To UBound(B, 2)
        If dic.Exists(B(i, 1) & B(j, 1)) Then Cells(i, 9) = dic(B(i, 1) & B(j, 1))
        Next j
    Next i
    
    'выгружает на весь диапазон только первую строку значений
    .Range("I9:M28") = dic.Items
    
    'выгружает на весь диапазон только Статья1Подразделение5
    '.Range("I9:M28") = dic.Items ()(i)
End With
 
End Sub

Решение задачи: «Выгрузка значений словаря»

textual
                            Листинг программы 
                        
 
                            
                        
Sub pramoy_code()
    Dim A, B
    Dim dic
    Dim i As Integer, j As Integer
    Set dic = CreateObject("Scripting.Dictionary")
    A = Worksheets("источник").[a1].CurrentRegion.Value
    For i = 2 To UBound(A)
        For j = 2 To UBound(A, 2)
            dic(A(i, 1) & A(1, j)) = A(i, j)
        Next j
    Next i
    With Worksheets(1)
        'B = .[a6].CurrentRegion.Value  ' пропущена первая .
        ' Получается результирующий диапазон A4:M28 - из-за шапки
        ' Для точной  разметки В в A6:M29 :
        B = .UsedRange.Offset(5, 0).Resize(.UsedRange.Rows.Count - 5, .UsedRange.Columns.Count).Value
        For i = 4 To UBound(B)
            'For j = 1 To UBound(B, 2)
            ' Если выводим в диапазон 2016 года I9:M28 без повторения в 2015
            For j = 9 To UBound(B, 2)
'Неправильно: If dic.Exists(B(i, 1) & B(j, 1)) Then Cells(i, 9) = dic(B(i, 1) & B(j, 1)) 'Пропущена первая .
              If dic.Exists(B(i, 1) & B(1, j)) Then .Cells(i + 5, j) = dic(B(i, 1) & B(1, j))
            Next j
        Next i
    End With
End Sub