crpt-aggregation/Module1.bas

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