Option Explicit
Option Base 1

Private Type MaterType
    LCnt As Long
    LNums() As Long
    Maters() As String
End Type

Sub Linkuem()
    Dim TList As ListObject, MTs() As MaterType, TNum, RNum, Arr(), TT(), TNums As New Collection
    Dim I As Long, J As Long, K As Long, H As Long
    Arr = [типы].Value
    H = UBound(Arr, 1)
    On Error Resume Next
    For K = 1 To H
        TNums.Add Arr(K, 1), CStr(Arr(K, 1))
    Next
    On Error GoTo 0
    ReDim MTs(TNums.Count)
    For Each TNum In TNums
        J = J + 1
        With MTs(J)
            ReDim .Maters(TNums.Count), .LNums(TNums.Count)
            K = 0
            For I = 1 To H
                If Arr(I, 1) = TNum Then
                    K = K + 1
                    .LNums(K) = Arr(I, 2)
                    .Maters(K) = Arr(I, 3)
                End If
            Next
            .LCnt = K
        End With
    Next
    Arr = [помещения].Value
    H = 0
    For K = 1 To UBound(Arr, 1)
        TNum = TNums(Arr(K, 2))
        H = H + MTs(TNum).LCnt
    Next
    ReDim TT(H, 3)
    I = 0
    For J = 1 To UBound(Arr, 1)
        RNum = Arr(J, 1)
        TNum = TNums(Arr(J, 2))
        With MTs(TNum)
            I = I + 1
            TT(I, 1) = RNum
            TT(I, 2) = TNum
            TT(I, 3) = .LNums(1) & ". " & .Maters(1)
            For K = 2 To .LCnt
                I = I + 1
                TT(I, 3) = .LNums(K) & ". " & .Maters(K)
            Next
        End With
    Next
    Set TList = Range("СБОР").ListObject
    H = H - TList.ListRows.Count
    If H Then
        Application.ScreenUpdating = False
        If H > 0 Then
            For I = 1 To H
                TList.ListRows.Add
            Next
        ElseIf H < 0 Then
            For I = TList.ListRows.Count To TList.ListRows.Count + H + 1 Step -1
                TList.ListRows(I).Delete
            Next
        End If
        Application.ScreenUpdating = True
    End If
    TList.DataBodyRange.Value = TT
End Sub

'Один-ко-многим по ключевому полю
'
'Заказчик: Jack Famous
'Воплотил идею в жизнь: С.М.
'Тема на форуме: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=84557&TITLE_SEO=84557-svyazat-2-tablitsy-v-odnu-makrosom-slozhnoe-obedinenie-dvukh-tablits&MID=705043&result=edit#message705043
'
'Присутствует проверка на соответствие ключей с перечислением несоответствий
'=======================================================================================================================================================================================================================
Option Explicit
Option Base 1

Sub One2Many()

    Dim DObj1 As New Class1, FObj1 As New Class1
    Dim ListObj As ListObject
    Dim DRng As Range, LRng As Range, FRng As Range
    Dim DArr(), LArr(), FArr(), Arr(), Item, Key
    Dim H As Long, J As Long, K As Long, L As Long
    Dim Txt As String, MsgRes As VbMsgBoxResult
    '
    Const ShowMaxLost As Long = 5 ' вывести макс. число не соответствующих ключей
    Dim LostObj As Class1
    '
    Application.DisplayAlerts = False
    
    On Error GoTo Exit1
    Set DRng = Application.InputBox("Укажите ячейку столбца ключевого поля словаря:", "Запрос данных. Шаг1.", , Type:=8).Cells(1)
    Set DRng = Intersect(DRng.EntireColumn, DRng.ListObject.DataBodyRange)
    Set LRng = Application.InputBox("Укажите ячейку столбца значений словаря для вставки:", "Запрос данных. Шаг2.", , Type:=8).Cells(1)
    Set LRng = Intersect(LRng.EntireColumn, LRng.ListObject.DataBodyRange)
    H = DRng.Rows.Count
    Set FRng = Application.InputBox("Укажите ячейку столбца ключевого поля таблицы_назначения:", "Запрос данных. Шаг3.", , Type:=8).Cells(1)
    Set ListObj = FRng.ListObject
    Set FRng = Intersect(FRng.EntireColumn, ListObj.DataBodyRange)
    FRng.Parent.Select
    DArr = DRng.Value ' ключи словаря '
    LArr = LRng.Value ' значения словаря '
    FArr = FRng.Value ' ключи таблицы_вставки '
    '
    For Each Item In FArr
        If Len(Item) Then FObj1.AddItem Item
    Next
    Set LostObj = New Class1
    For Each Item In DArr
        If Len(Item) Then
            If FObj1.Exists(Item) Then
                DObj1.AddItem Item
            Else ' ключа словаря нет в таблице_вставки
                LostObj.AddItem Item
            End If
        End If
    Next
    K = LostObj.Count
    If K Then
        Txt = "Не все ключи словаря найдены в таблице_назначения"
        GoSub Routine1
    End If
    '
    Set LostObj = New Class1
    For Each Key In FObj1.Keys
        If Not DObj1.Exists(Key) Then ' ключа таблицы_вставки нет в словаре
            LostObj.AddItem Key
        End If
    Next
    K = LostObj.Count
    If K Then
        Txt = "Ключу в таблице_назначения нет соответствия ключей словаря"
        GoSub Routine1
    End If
    '
    For Each Key In DObj1.Keys
        ReDim Arr(H)
        J = 0
        For K = 1 To H
            If CStr(DArr(K, 1)) = Key Then
                J = J + 1: Arr(J) = LArr(K, 1)
            End If
        Next
        ReDim Preserve Arr(J)
        DObj1.Item(Key) = WorksheetFunction.Transpose(Arr)
    Next
    '
    
    Application.ScreenUpdating = False
    
    ListObj.ListColumns.Add
    FRng.Columns(2).EntireColumn.Insert
    FRng.Cells(0, 2) = LRng.Cells(0, 1)
    For K = FRng.Rows.Count To 1 Step -1
        Item = FArr(K, 1)
        If Len(Item) Then
            If DObj1.Exists(Item) Then
                Arr = DObj1.Items(CStr(Item))
                H = UBound(Arr)
                L = K + 1
                For J = 1 To H - 1
                    ListObj.ListRows.Add L
                Next
                FRng.Cells(K, 2).Resize(H).Value = Arr
            End If
        End If
    Next
    ListObj.ListColumns(ListObj.ListColumns.Count).Delete
    
    Application.ScreenUpdating = True
    
    Exit Sub
Routine1:
    ReDim Arr(K)
    J = 0
    For Each Key In LostObj.Keys
        J = J + 1: Arr(J) = "    " & Key
    Next
    If K > ShowMaxLost Then
        K = ShowMaxLost + 1
        ReDim Preserve Arr(K): Arr(K) = "    ......."
        Txt = Txt & " [" & J & "]"
    End If
    Txt = Txt & ":" & vbCr & Join(Arr, vbCr) & vbCr & "Продолжить выполнение ?"
    If MsgBox(Txt, vbInformation + vbOKCancel + vbDefaultButton2, "Запрос данных.") = vbCancel Then Exit Sub
Return
Exit1:
    Err.Clear
    MsgBox "Диапазон не выбран.", , "Запрос данных."
    
    Application.ScreenUpdating = True
    
End Sub

Option Explicit
Option Base 1

Dim HisKeys As New Collection
Dim HisItems As New Collection
Dim Indexes As New Collection
'

Sub AddItem(ByVal Key As String, Optional Item = Empty)
    On Error Resume Next
    HisKeys.Add Key, Key
    If Err = 0 Then
        HisItems.Add Item, Key
        Indexes.Add Indexes.Count + 1, Key
    Else
        Err.Clear
    End If
End Sub 'AddItem'

Property Get Exists(ByVal Key As String) As Boolean
    On Error Resume Next
    HisKeys.Add Empty, Key
    If Err Then
        Err.Clear: Exists = True
    Else
        HisKeys.Remove Key
    End If
End Property 'Exists'

Property Let Item(ByVal Key As String, NewValue)
    Dim I As Long
    On Error Resume Next
    HisKeys.Add Empty, Key
    If Err Then
        Err.Clear: I = Indexes.Item(Key)
        HisItems.Remove I
        If I > 1 Then HisItems.Add NewValue, Key, , I - 1 Else HisItems.Add NewValue, Key, I
    Else
        HisKeys.Remove Key
    End If
End Property 'Item'

Property Get Items()
    Set Items = HisItems
End Property

Property Get Keys()
    Set Keys = HisKeys
End Property

Property Get Count() As Long
    Count = HisItems.Count
End Property