Option Explicit
Sub Main()
Dim arr(), aDL(), S, res(), res2()
Dim sRow&, k&, i&, j&, iTem$, QTy#, iCD$
For i = 5 To 7
Range("J" & i).Font.Color = -16776961
Next i
With Sheets("Import")
aDL = .Range("A3:I" & .Range("A1048000").End(xlUp).Row).Value
End With
sRow = UBound(aDL)
ReDim res(1 To sRow, 1 To 8)
ReDim res2(1 To sRow, 1 To 8)
With Sheets("Check")
arr = .Range("B2:D" & .Range("B1048000").End(xlUp).Row).Value
End With
For i = 1 To UBound(arr)
iTem = arr(i, 1): QTy = arr(i, 2): iCD = CStr(arr(i, 3))
If iTem <> Empty And QTy > 0 Then
If iCD <> Empty Then
Call SumFind(aDL, res, k, sRow, iTem, QTy, iCD)
End If
End If
Next i
With Sheets("Result")
i = .Range("A1048000").End(xlUp).Row
If i > 2 Then .Range("A3:H" & i).Clear
If k Then
.Range("A3").Resize(k, 8) = res
.Range("A3").Resize(k, 8).Borders.LineStyle = 1
For i = 3 To k + 2
If .Range("B" & i).Value = Empty Then .Range("A" & i).Font.Color = -16776961
Next i
End If
End With
k = 0
ReDim res(1 To sRow, 1 To 8)
For i = 1 To UBound(arr)
iTem = arr(i, 1): QTy = arr(i, 2): iCD = CStr(arr(i, 3))
If iCD = Empty Then
If iTem <> Empty And QTy > 0 Then
Call SumFind(aDL, res, k, sRow, iTem, QTy, iCD)
End If
End If
Next i
With Sheets("Result2")
i = .Range("A1048000").End(xlUp).Row
If i > 2 Then .Range("A3:H" & i).Clear
If k Then
.Range("A3").Resize(k, 8) = res
.Range("A3").Resize(k, 8).Borders.LineStyle = 1
For i = 3 To k + 2
If .Range("B" & i).Value = Empty Then .Range("A" & i).Font.Color = -16776961
Next i
End If
End With
End Sub
Private Sub SumFind(aDL, aRes, k, sRow, iTem, QTy, iCD)
Dim Data(), arr(), S, tmp#, tSum#, dMin#, i&, N&, q&, j&, r&, t$
dMin = 1000000000
For i = 1 To sRow
tmp = aDL(i, 9)
If aDL(i, 1) = iTem And tmp > 0 Then
If CStr(aDL(i, 2)) = iCD Or iCD = Empty Then
If tmp = QTy Then
k = k + 1
For j = 1 To 6
aRes(k, j) = aDL(i, j)
Next j
aRes(k, 7) = aDL(i, 8): aRes(k, 8) = aDL(i, 9)
aDL(i, 1) = Empty
Exit Sub
ElseIf tmp > QTy Then
If dMin > tmp Then dMin = tmp: t = "," & i
ElseIf tmp > 0 Then
N = N + 1
ReDim Preserve Data(1 To 2, 1 To N)
Data(1, N) = tmp: Data(2, N) = i
End If
End If
End If
Next i
If N > 0 Then
Call QuickSort(Data)
ReDim arr(1 To N)
arr(1) = 1: tSum = Data(1, 1)
N = 1: q = 1
Do While QTy <> -1 'tSum
If arr(1) = UBound(Data, 2) Then Exit Do
If tSum > QTy Then
If dMin > tSum Then
dMin = tSum
t = Empty
For i = 1 To N
t = t & "," & Data(2, arr(i))
Next i
End If
q = arr(N - 1) + 1
tSum = tSum - Data(1, arr(N)) - Data(1, arr(N - 1)) + Data(1, q)
N = N - 1
arr(N) = q
Else
If q = UBound(Data, 2) Then
q = arr(N - 1) + 1
tSum = tSum - Data(1, arr(N)) - Data(1, arr(N - 1)) + Data(1, q)
N = N - 1
arr(N) = q
Else
q = q + 1
tSum = tSum + Data(1, q)
N = N + 1
arr(N) = q
End If
End If
If QTy = tSum Then
t = Empty
For i = 1 To N
t = t & "," & Data(2, arr(i))
Next i
Exit Do
End If
Loop
End If
If t <> Empty Then
S = Split(t, ",")
For i = 1 To UBound(S)
r = CLng(S(i))
k = k + 1
For j = 1 To 6
aRes(k, j) = aDL(r, j)
Next j
aRes(k, 7) = aDL(r, 8): aRes(k, 8) = aDL(r, 9)
aDL(r, 1) = Empty
Next i
Else
k = k + 1
aRes(k, 1) = iTem
End If
End Sub
Private Sub QuickSort(Data)
Dim oSList As Object, sArr, S, j&, k&, jk&, m&
Set oSList = CreateObject("System.Collections.SortedList")
For j = LBound(Data, 2) To UBound(Data, 2)
oSList.iTem(Data(1, j)) = oSList.iTem(Data(1, j)) & "," & j
Next j
sArr = Data
For j = 0 To oSList.Count - 1
S = Split(oSList.GetByIndex(j), ",")
For m = 1 To UBound(S)
jk = CLng(S(m))
k = k + 1
Data(1, k) = sArr(1, jk): Data(2, k) = sArr(2, jk)
Next m
Next j
Set oSList = Nothing
End Sub
