CRPT agrregation tool

2026-05-08 14:59:56 +03:00
commit e6769a47b7
28 changed files with 1567433 additions and 0 deletions
--- a/DistributeItems.bas
+++ b/DistributeItems.bas
@@ -0,0 +1,220 @@
+Option Explicit
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: <20><><EFBFBD><EFBFBD> item-<2D><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> + 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
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
+    Set wsMap = ThisWorkbook.Worksheets("Map")
+    Set wsItems = ThisWorkbook.Worksheets("Items")
+    Set wsSets = ThisWorkbook.Worksheets("Sets")
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>
+    On Error Resume Next
+    Application.DisplayAlerts = False
+    ThisWorkbook.Worksheets("Assignments").Delete
+    ThisWorkbook.Worksheets("Errors").Delete
+    Application.DisplayAlerts = True
+    On Error GoTo 0
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+    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 dictPointers = CreateObject("Scripting.Dictionary")
+    Set dictSets = CreateObject("Scripting.Dictionary")
+    Set dictMap = CreateObject("Scripting.Dictionary")
+    
+    ' ---------------- 1) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Items -> dictItems (<28><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>) ----------------
+    lastRow = wsItems.Cells(wsItems.Rows.Count, "A").End(xlUp).Row
+    Dim tempMap As Object
+    Set tempMap = CreateObject("Scripting.Dictionary") ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> 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
+    
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Collection -> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 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   ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (1-based)
+    Next key
+    Set tempMap = Nothing
+    
+    ' ---------------- 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 ----------------
+    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)  ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 3, 3.00, "3" <20> <20>.<2E>.
+        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) <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> + 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
+                    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD> <20><><EFBFBD> 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
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+                            Dim takeCode As String
+                            takeCode = CStr(arrCodes(ptr))
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>)
+                            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
+                            ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> pointer
+                            dictPointers(neededItemGTIN) = CLng(ptr) + 1
+                        Else
+                            ' <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 1 <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+                            LogError_Text wsErr, errRow, neededItemGTIN, 1, 0
+                            errRow = errRow + 1
+                        End If
+                    Else
+                        ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+                        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 "<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><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> ----------------
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> count: <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> "3", "3.00", "3,00" <20> <20>.<2E>. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 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
+    ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD>; <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD>
+    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
+    ' <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
+    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
+
+' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
+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