Option Explicit

' Исправленная версия: пулы item-кодов хранятся как массив + pointer.
Sub DistributeItemsToSets_TextOutput_Fix()
    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 -> array of codes (Variant)
    Dim dictPointers As Object     ' ITEM_GTIN -> Long (next index to take, 1-based)
    Dim dictSets As Object         ' SET_GTIN -> Collection of set codes
    Dim dictMap As Object          ' SET_GTIN -> Collection of "ITEMGTIN|COUNT"
    Dim r As Long
    Dim key As Variant
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Листы (поменяйте названия при необходимости)
    Set wsMap = ThisWorkbook.Worksheets("Map")
    Set wsItems = ThisWorkbook.Worksheets("Items")
    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 dictPointers = 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
    Dim tempMap As Object
    Set tempMap = CreateObject("Scripting.Dictionary") ' временно собираем списки в Collections
    
    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 tempMap.Exists(itemGTIN) Then
                tempMap.Add itemGTIN, New Collection
            End If
            tempMap(itemGTIN).Add itemCode
        End If
    Next r
    
    ' Преобразуем Collection -> массив и инициализируем pointers
    Dim coll As Collection
    For Each key In tempMap.Keys
        Set coll = tempMap(key)
        Dim arr() As Variant
        ReDim arr(1 To coll.Count)
        Dim ii As Long
        For ii = 1 To coll.Count
            arr(ii) = CStr(coll(ii))
        Next ii
        dictItems.Add CStr(key), arr
        dictPointers.Add CStr(key), 1   ' следующий индекс для выдачи (1-based)
    Next key
    Set tempMap = Nothing
    
    ' ---------------- 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 ----------------
    lastRow = wsMap.Cells(wsMap.Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRow
        Dim mapSetGTIN As String, mapItemGTIN As String
        Dim cntRaw As String, cnt As Long
        mapSetGTIN = Trim(CStr(wsMap.Cells(r, 1).Text))
        mapItemGTIN = Trim(CStr(wsMap.Cells(r, 4).Text))
        cntRaw = Trim(CStr(wsMap.Cells(r, 5).Text))
        cnt = ParseCountToLong(cntRaw)  ' безопасно парсим 3, 3.00, "3" и т.д.
        If cnt < 1 Then cnt = 1
        If mapSetGTIN <> "" And mapItemGTIN <> "" Then
            If Not dictMap.Exists(mapSetGTIN) Then
                dictMap.Add mapSetGTIN, New Collection
            End If
            dictMap(mapSetGTIN).Add mapItemGTIN & "|" & CStr(cnt)
        End If
    Next r
    
    ' ---------------- 4) Основное распределение (используя массивы + pointers) ----------------
    Dim outRow As Long: outRow = 2
    Dim errRow As Long: errRow = 2
    For Each key In dictSets.Keys
        Dim curSetGTIN As String: curSetGTIN = CStr(key)
        If Not dictMap.Exists(curSetGTIN) Then GoTo NextSetGTIN_Fix
        
        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 = CStr(setCodesColl(si))
            
            Dim mi As Long
            For mi = 1 To mapColl.Count
                Dim parts As Variant
                parts = Split(mapColl(mi), "|")
                Dim neededItemGTIN As String: neededItemGTIN = CStr(parts(0))
                Dim neededCnt As Long: neededCnt = CLng(parts(1))
                
                Dim j As Long
                For j = 1 To neededCnt
                    ' Проверяем, есть ли пул для neededItemGTIN
                    If dictItems.Exists(neededItemGTIN) Then
                        Dim arrCodes As Variant
                        arrCodes = dictItems(neededItemGTIN)
                        Dim ptr As Long
                        ptr = CLng(dictPointers(neededItemGTIN))
                        If ptr <= UBound(arrCodes) Then
                            ' взять текущий код по указателю
                            Dim takeCode As String
                            takeCode = CStr(arrCodes(ptr))
                            ' записать в результат (строки как текст)
                            wsOut.Cells(outRow, 1).NumberFormat = "@"
                            wsOut.Cells(outRow, 2).NumberFormat = "@"
                            wsOut.Cells(outRow, 3).NumberFormat = "@"
                            wsOut.Cells(outRow, 4).NumberFormat = "@"
                            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
                            ' увеличить pointer
                            dictPointers(neededItemGTIN) = CLng(ptr) + 1
                        Else
                            ' пул кончился — логируем 1 недостающую единицу
                            LogError_Text wsErr, errRow, neededItemGTIN, 1, 0
                            errRow = errRow + 1
                        End If
                    Else
                        ' вообще нет пула — логируем нужное количество
                        LogError_Text wsErr, errRow, neededItemGTIN, neededCnt, 0
                        errRow = errRow + 1
                        Exit For
                    End If
                Next j
            Next mi
        Next si
NextSetGTIN_Fix:
    Next key
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Готово. Результат в листе 'Assignments'. Ошибки — в листе 'Errors' (если есть).", vbInformation
End Sub

' ---------------- Вспомогательные процедуры ----------------

' Безопасный парсер count: принимает "3", "3.00", "3,00" и т.п. Возвращает Long
Private Function ParseCountToLong(s As String) As Long
    Dim t As String
    t = Trim(s)
    If t = "" Then
        ParseCountToLong = 1
        Exit Function
    End If
    ' Заменим запятую на точку; оставим только цифры и точку
    t = Replace(t, ",", ".")
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[^0-9.]"
    re.Global = True
    t = re.Replace(t, "")
    If t = "" Then
        ParseCountToLong = 1
        Exit Function
    End If
    ' берем целую часть
    Dim posDot As Long
    posDot = InStr(t, ".")
    If posDot > 0 Then t = Left(t, posDot - 1)
    If t = "" Then
        ParseCountToLong = 1
    Else
        ParseCountToLong = CLng(Val(t))
        If ParseCountToLong < 1 Then ParseCountToLong = 1
    End If
End Function

' Логирование ошибок — пишет текстом
Sub LogError_Text(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