Скрипт (VBA) на распределение предметов

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

Лист 4. Сводная таблица на распределение предметов / зарядок по постройкам. Скрипт на распределение предметов / зарядок по постройкам: 1. ID постройки. 2. Группа ценности # / ID. В данных столбцах указываются зарядки и предметы которые можно найти в указанной постройке с разделением по группам ценности. Заполнение указанных столбцов осуществляется при помощи написанного скрипта. Запуск скрипта осуществляется через кнопку на этом же листе. Прикреплю весь документ, где задание, если не понятно, и соответственно, сам Excel.

Решение задачи: «Скрипт (VBA) на распределение предметов»

textual
                            Листинг программы 
                        
 
                            
                        
Sub Raspredelenie()
    Dim i%, j%, k%, S$, A, Dic, Msg$
    Dim B, Z, C 'переменные для массивов значений с листов "buildings", "chargers" , "collections"
    B = Sheets("buildings").Range("B4:C15").Value
    Z = Sheets("chargers").Range("A11:N40").Value
    C = Sheets("collections").Range("A4:R33").Value
    Set Dic = CreateObject("Scripting.Dictionary") 'создаем объект словарь
    Dic.CompareMode = 1 'независимое от регистра сравнение
    For i = 1 To UBound(Z)
        For j = 7 To 8
            If Trim(Z(i, j)) <> "" Then
                S = Z(i, j) & "_" & format(Z(i, 4))
                If Dic.Exists(S) Then
                   Dic(S) = Dic(S) & "|" & Z(i, 3)
                Else
                   Dic(S) = Z(i, 3)
                End If
            End If
        Next j
    Next i
    For i = 1 To UBound(C)
        S = C(i, 13) & "_" & format(C(i, 5))
        If Dic.Exists(S) Then
           Dic(S) = Dic(S) & "|" & C(i, 4)
        Else
           Dic(S) = C(i, 4)
        End If
    Next i
    With Sheets("items")
        .Range("C4:G183").ClearContents
        For i = 1 To 12
             For j = 1 To 5
                 S = B(i, 1) & "_" & format(j)
                 If Dic.Exists(S) Then
                     A = Split(Dic(S), "|")
                     For k = 0 To UBound(A)
                        .Cells(i * 15 - 11 + k, j + 2) = A(k)
                         If k = 15 And UBound(A) > 14 Then
                            Msg = Msg & "В блоке " & S & " не хватило ячеек для распределения " & A(15) & vbCrLf
                            .Cells(i * 15 - 11 + k, j + 2) = Mid(Dic(S), InStr(1, Dic(S), A(k)))
                            Exit For
                         End If
                     Next
                 End If
             Next j
        Next i
    End With
    Set Dic = Nothing
    If Msg <> "" Then MsgBox Msg
End Sub