CRPT agrregation tool

2026-05-08 14:59:56 +03:00
commit e6769a47b7
28 changed files with 1567433 additions and 0 deletions
--- a/Module1.bas
+++ b/Module1.bas
@@ -0,0 +1,219 @@
+Attribute VB_Name = "Module1"
+Option Explicit
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+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
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>)
+    Set wsMap = ThisWorkbook.Worksheets("Map")
+    Set wsItems = ThisWorkbook.Worksheets("Units")
+    Set wsSets = ThisWorkbook.Worksheets("Sets")
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>/<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
+    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")
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    Set dictItems = CreateObject("Scripting.Dictionary")
+    Set dictSets = CreateObject("Scripting.Dictionary")
+    Set dictMap = CreateObject("Scripting.Dictionary")
+    
+    ' ---- 1) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 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) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 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) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Map -> dictMap
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: A - set gtin, D - ITEM GTIN, E - COUNT (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
+    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
+            ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> "ITEMGTIN|COUNT"
+            dictMap(mapSetGTIN).Add mapItemGTIN & "|" & CStr(cnt)
+        End If
+    Next r
+    
+    ' ---- 4) <20><><EFBFBD><EFBFBD><EFBFBD>: <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> item-<2D><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    Dim doShuffle As Boolean
+    doShuffle = False  ' <-- <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> True <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    If doShuffle Then
+        For Each key In dictItems.Keys
+            dictItems(key) = ShuffleCollection(dictItems(key))
+        Next key
+    End If
+    
+    ' ---- 5) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>: <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> SET_GTIN, <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> SET_CODE - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> items <20><> 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
+            ' <20><><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> set gtin <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> Map <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
+            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)
+            
+            ' <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD> itemGTIN,COUNT <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+            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
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+                            Dim takeCode As String
+                            takeCode = CStr(col(1))
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+                            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
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD>
+                            RemoveAtCollection col, 1
+                        Else
+                            ' <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 1)
+                            LogError wsErr, errRow, neededItemGTIN, 1, 0
+                            errRow = errRow + 1
+                        End If
+                    Else
+                        ' <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> 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) <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
+    ' (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>) <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    
+    Application.Calculation = xlCalculationAutomatic
+    Application.ScreenUpdating = True
+    
+    MsgBox "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD> 'Assignments'. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20> <20><><EFBFBD><EFBFBD><EFBFBD> 'Errors' (<28><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>).", vbInformation
+End Sub
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> 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
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    Do While coll.Count > 0
+        coll.Remove 1
+    Loop
+    For i = 1 To tmp.Count
+        coll.Add tmp(i)
+    Next i
+End Sub
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
+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
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Collection -> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> 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
+