Sub transform_table()
Dim dict As Object, arr, key, item, names_arr(), title
Dim i, j, tmp, lr, f
Set dict = CreateObject("Scripting.Dictionary")
title = Array("Муниципальное образование", "Социальная сфера", "Местное самоуправление", _
                "Бизнес", "Экономика и финансы", "Архитектура и строительство", _
                "Спорт и военная подготовка", "Комфортная среда", "Индустрия гостеприимства", _
                "Инфотех", "Сельское хозяйство")

With ThisWorkbook.Worksheets("Лист1")
    arr = .Cells(1, 1).CurrentRegion
End With

For i = 2 To UBound(arr, 1)
    key = arr(i, 1)
    If Not dict.exists(key) Then
        dict.Add key, arr(i, 2) & ":" & arr(i, 4)
    Else
        dict(key) = dict(key) & ";" & arr(i, 2) & ":" & arr(i, 4)
    End If
Next i
' выгрузка на лист
With ThisWorkbook.Worksheets("Лист2")
.Cells.Clear
.Cells(1, 1).Resize(1, UBound(title) + 1) = title
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
For Each f In dict.keys()
    For j = LBound(title) To UBound(title)
        If j = 0 Then
            .Cells(lr + 1, 1) = f
        Else
            item = find_in_dict(dict, title(j), f)
            .Cells(lr + 1, j + 1) = item
        End If
    Next j
    lr = lr + 1
Next f
.ListObjects.Add(xlSrcRange, Range("$A$1:$K$60"), , xlYes).Name = _
        "Таблица1"
End With
End Sub
Private Function find_in_dict(arr, what, key) As Variant
Dim j, tmp, i, item
find_in_dict = 0
For Each j In arr.keys()
    If key = j Then
        tmp = Split(arr(j), ";")
        For Each i In tmp
            item = Split(i, ":")
            If item(0) = what Then find_in_dict = item(1): Exit Function
        Next i
    End If
Next j
End Function