Транспонирование пар значений

Dim a       
Dim i            
Dim j                         
 For i = 1 j = 5                   
 If notEmpty (cells(i, j)) Then a= count cells                  
End If 
Next j 
'пробег по индексам строки и столбца, начиная с 5го столбца, посчитать непустые ячейки, сохранить количество) 
Next i

Sub словарь_с_коллекцией()    'коллекция в словаре
    Dim a, i&, t$, Dic As Object
    Dim el, col
 
    a = Range("A1").CurrentRegion.Value
 
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = i
            .Add t, New Collection
            For ii = 3 To UBound(a, 2) Step 2
                If Len(a(i, ii)) Then .Item(t).Add Array(a(i, ii), a(i, ii + 1))
            Next
        Next
    End With
 
    With Workbooks.Add(1).Sheets(1)
 
        i = 0
        For Each el In Dic.keys
            i = i + 1
            .Cells(i, 1).Resize(, 2).Value = Array(a(el, 1), a(el, 2)): i = i - 1
            For Each col In Dic.Item(el)
                i = i + 1
                .Cells(i, 3).Resize(, 2).Value = col
            Next
        Next
 
        .UsedRange.Columns(2).NumberFormat = "0.00"
    End With
End Sub