221 lines
8.9 KiB
QBasic
221 lines
8.9 KiB
QBasic
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
|