Attribute VB_Name = "Module1"
Option Explicit

' Главный субрутине
Sub DistributeItemsToSets()
    Dim wsMap As Worksheet, wsItems As Worksheet, wsSets As Worksheet
    Dim wsOut As Worksheet, wsErr As Worksheet
    Dim lastRow As Long
    Dim dictItems As Object             ' ITEM_GTIN -> Collection of item codes available
    Dim dictSets As Object              ' SET_GTIN -> Collection of set codes available
    Dim dictMap As Object               ' SET_GTIN -> Collection of (ITEM_GTIN, COUNT) pairs
    Dim r As Long, i As Long
    Dim key As Variant
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Листы (поменяйте названия, если нужно)
    Set wsMap = ThisWorkbook.Worksheets("Map")
    Set wsItems = ThisWorkbook.Worksheets("Units")
    Set wsSets = ThisWorkbook.Worksheets("Sets")
    
    ' Создать/очистить выходные листы
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("Assignments").Delete
    ThisWorkbook.Worksheets("Errors").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsOut = ThisWorkbook.Worksheets.Add
    wsOut.Name = "Assignments"
    wsOut.Cells.NumberFormat = "@"
    wsOut.Range("A1:D1").Value = Array("SET_GTIN", "SET_CODE", "ITEM_GTIN", "ITEM_CODE")
    
    Set wsErr = ThisWorkbook.Worksheets.Add
    wsErr.Name = "Errors"
    wsErr.Cells.NumberFormat = "@"
    wsErr.Range("A1:D1").Value = Array("ITEM_GTIN", "NEEDED", "AVAILABLE", "MISSING")
    
    ' Инициализация словарей
    Set dictItems = CreateObject("Scripting.Dictionary")
    Set dictSets = CreateObject("Scripting.Dictionary")
    Set dictMap = CreateObject("Scripting.Dictionary")
    
    ' ---- 1) Считать Items -> dictItems
    lastRow = wsItems.Cells(wsItems.Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRow
        Dim itemCode As String, itemGTIN As String
        itemCode = Trim(CStr(wsItems.Cells(r, 1).Text))
        itemGTIN = Trim(CStr(wsItems.Cells(r, 2).Text))
        If itemGTIN <> "" And itemCode <> "" Then
            If Not dictItems.Exists(itemGTIN) Then
                dictItems.Add itemGTIN, New Collection
            End If
            dictItems(itemGTIN).Add itemCode
        End If
    Next r
    
    ' ---- 2) Считать Sets -> dictSets
    lastRow = wsSets.Cells(wsSets.Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRow
        Dim setCode As String, setGTIN As String
        setCode = Trim(CStr(wsSets.Cells(r, 1).Text))
        setGTIN = Trim(CStr(wsSets.Cells(r, 2).Text))
        If setGTIN <> "" And setCode <> "" Then
            If Not dictSets.Exists(setGTIN) Then
                dictSets.Add setGTIN, New Collection
            End If
            dictSets(setGTIN).Add setCode
        End If
    Next r
    
    ' ---- 3) Считать Map -> dictMap
    ' Предполагаются столбцы: A - set gtin, D - ITEM GTIN, E - COUNT (поменяйте индексы если разные)
    lastRow = wsMap.Cells(wsMap.Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRow
        Dim mapSetGTIN As String, mapItemGTIN As String
        Dim cnt As Long
        mapSetGTIN = Trim(CStr(wsMap.Cells(r, 1).Text))
        mapItemGTIN = Trim(CStr(wsMap.Cells(r, 4).Text))
        cnt = 1
        If IsNumeric(wsMap.Cells(r, 5).Value) Then cnt = CLng(wsMap.Cells(r, 5).Value)
        If mapSetGTIN <> "" And mapItemGTIN <> "" Then
            If Not dictMap.Exists(mapSetGTIN) Then
                dictMap.Add mapSetGTIN, New Collection
            End If
            ' добавим запись в формате "ITEMGTIN|COUNT"
            dictMap(mapSetGTIN).Add mapItemGTIN & "|" & CStr(cnt)
        End If
    Next r
    
    ' ---- 4) Опция: перемешать пулы item-кодов для случайного распределения
    Dim doShuffle As Boolean
    doShuffle = False  ' <-- поставьте True если хотите случайное распределение
    If doShuffle Then
        For Each key In dictItems.Keys
            dictItems(key) = ShuffleCollection(dictItems(key))
        Next key
    End If
    
    ' ---- 5) Основной цикл: для каждого SET_GTIN, для каждого SET_CODE - присвоить items по dictMap
    Dim outRow As Long: outRow = 2
    Dim errRow As Long: errRow = 2
    For Each key In dictSets.Keys
        Dim curSetGTIN As String: curSetGTIN = key
        If Not dictMap.Exists(curSetGTIN) Then
            ' Если для данного set gtin нет записей в Map — пропускаем (можно логировать)
            GoTo NextSetGTIN
        End If
        
        Dim setCodesColl As Collection: Set setCodesColl = dictSets(curSetGTIN)
        Dim mapColl As Collection: Set mapColl = dictMap(curSetGTIN)
        
        Dim si As Long
        For si = 1 To setCodesColl.Count
            Dim curSetCode As String: curSetCode = setCodesColl(si)
            
            ' Для данного экземпляра набора пройдём по всем itemGTIN,COUNT и отрежем нужное количество
            Dim mi As Long
            For mi = 1 To mapColl.Count
                Dim parts As Variant
                parts = Split(mapColl(mi), "|")
                Dim neededItemGTIN As String: neededItemGTIN = parts(0)
                Dim neededCnt As Long: neededCnt = CLng(parts(1))
                
                Dim j As Long
                For j = 1 To neededCnt
                    If dictItems.Exists(neededItemGTIN) Then
                        Dim col As Collection: Set col = dictItems(neededItemGTIN)
                        If col.Count > 0 Then
                            ' взять первый элемент
                            Dim takeCode As String
                            takeCode = CStr(col(1))
                            ' записать в результат
                            wsOut.Cells(outRow, 1).Value = CStr(curSetGTIN)
                            wsOut.Cells(outRow, 2).Value = CStr(curSetCode)
                            wsOut.Cells(outRow, 3).Value = CStr(neededItemGTIN)
                            wsOut.Cells(outRow, 4).Value = CStr(takeCode)
                            outRow = outRow + 1
                            ' удалить использованный код из пула
                            RemoveAtCollection col, 1
                        Else
                            ' Нету доступных — лог ошибки (недостаёт 1)
                            LogError wsErr, errRow, neededItemGTIN, 1, 0
                            errRow = errRow + 1
                        End If
                    Else
                        ' Нет вообще пула для этого ITEM GTIN
                        LogError wsErr, errRow, neededItemGTIN, neededCnt, 0
                        errRow = errRow + 1
                        Exit For
                    End If
                Next j
            Next mi
        Next si
NextSetGTIN:
    Next key
    
    ' ---- 6) После распределения можно вывести оставшиеся в пуле (неиспользованные)
    ' (опционально) — закомментировал
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Готово. Результат в листе 'Assignments'. Ошибки — в листе 'Errors' (если есть).", vbInformation
End Sub

' Утилита: удалить элемент по индексу из Collection
Sub RemoveAtCollection(ByRef coll As Collection, ByVal idx As Long)
    Dim i As Long
    Dim tmp As Collection
    Set tmp = New Collection
    For i = 1 To coll.Count
        If i <> idx Then tmp.Add coll(i)
    Next i
    ' очистить исходную и переложить элементы обратно
    Do While coll.Count > 0
        coll.Remove 1
    Loop
    For i = 1 To tmp.Count
        coll.Add tmp(i)
    Next i
End Sub

' Утилита: логирование ошибки (недостаёт)
Sub LogError(ws As Worksheet, ByVal ByRefRow As Long, itemGTIN As String, needed As Long, available As Long)
    ws.Cells.NumberFormat = "@"
    ws.Cells(ByRefRow, 1).Value = CStr(itemGTIN)
    ws.Cells(ByRefRow, 2).Value = CStr(needed)
    ws.Cells(ByRefRow, 3).Value = CStr(available)
    ws.Cells(ByRefRow, 4).Value = CStr(needed - available)
End Sub

' Утилита: перемешать Collection -> возвращает новую Collection
Function ShuffleCollection(collIn As Collection) As Collection
    Dim arr() As Variant
    Dim n As Long, i As Long
    n = collIn.Count
    ReDim arr(1 To n)
    For i = 1 To n
        arr(i) = collIn(i)
    Next i
    Dim rndIndex As Long, tmp As Variant
    Randomize
    For i = n To 2 Step -1
        rndIndex = Int(Rnd() * i) + 1
        tmp = arr(i)
        arr(i) = arr(rndIndex)
        arr(rndIndex) = tmp
    Next i
    Dim outColl As Collection
    Set outColl = New Collection
    For i = 1 To n
        outColl.Add arr(i)
    Next i
    Set ShuffleCollection = outColl
End Function