let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    a = Table.AddIndexColumn(Источник, "q"),
    b = Table.AddColumn(a, "q1", each if [Название столбца] = "Сведения о постановке на учет российской организации в налоговом органе по месту нахождения транспортного средства" then [q] else null),
    c = Table.FillDown(b,{"q1"}),
    d = Table.RemoveColumns(c,{"q"}),
    f = Table.Pivot(d, List.Distinct(d[#"Название столбца"]), "Название столбца", "Данные столбца")
in
    f

Sub Транспонировать_таблицу_на_лист_Результат()
Dim arrData, i As Long, oDic As Object, LastRow As Long, iRow As Long, arrItems, arrKeys

    With Worksheets("База")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя строка в Базе
        arrData = .Range("A2:B" & LastRow).Value 'все данные из базы в массив
    End With
    
    Set oDic = CreateObject("Scripting.Dictionary")
    oDic.comparemode = 1
    iRow = 1
    With Worksheets("Результат")
        For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            oDic.Add .Cells(1, i).Text, i  'add key, item
        Next i
        arrItems = oDic.Items
        arrKeys = oDic.keys
        For i = 1 To UBound(arrData)
            If arrData(i, 1) = arrData(1, 1) Then
                iRow = iRow + 1
            End If
            .Cells(iRow, CLng(oDic.Item(arrData(i, 1)))) = arrData(i, 2)
        Next i
    End With
    MsgBox "Транспонирование таблицы завершено!", vbInformation, "Конец"
End Sub