已更新以添加缺少的功能... 以下代码将在您的列表框中旋转，寻找匹配的“批号”并选择可提供所需数量的行。列表框数量被放置到一个数组中，然后进行排序，以便首先使用最小数量来释放大多数垃圾箱。我懒得让代码取消选择多个先前选择的行来达到正确的数量，但是一个 msgbox 会提醒你这一点。只需调用传递数量和 Lot# 的函数即可。
Option Compare Database
Option Explicit
Dim myarray() As Variant
Private Sub cmdSearchBins_Click()
Mark_ListBox_Rows Me.txtQty, "Lot-A"
End Sub
Function Mark_ListBox_Rows(Qty As Integer, LotNbr As String)
Dim i As Integer
Dim i2 As Integer
Dim iStart As Integer
Dim iQty As Integer
Dim iReserved As Integer
Dim iAddRow As Integer
Dim iColUsed As Integer
Dim iMaxQtyAvail As Integer
'(1)Either pass the qty (and Lot #) to this routine, or change code to get Qty from another control and set iQty
'(2) Modify code for correct column (I am using col 4 (3 if relative to zero))
'(3) Most times automatic selection will be made. If unable to find simple (one row) solution, let the user pick.
iColUsed = 3 ' (relative to zero)
iMaxQtyAvail = 0
If IsNull(Qty) Or Qty = 0 Then
MsgBox "You must specify the Quantity!", vbOKOnly, "No Quantity Entered"
Exit Function
End If
If Me.List2.ColumnHeads = True Then ' Check if listbox has headings
iStart = 1 ' Adjust starting row + 1
Else
iStart = 0
End If
ReDim myarray(Me.List2.ListCount, 2) 'Resize Array as needed
'Populate Array with ListBox Row & Qty
i2 = 0
For i = 0 To Me.List2.ListCount ' Spin through listbox
If Me.List2.Column(2, iStart + i) = LotNbr Then ' Make sure Lot # matches
If Me.List2.Column(iColUsed, iStart + i) <> 0 Then ' Make sure not = 0 (doubt it is in your list, but...)
myarray(i2, 0) = iStart + i2 ' Save Row number, then Qty
myarray(i2, 1) = Int(Me.List2.Column(iColUsed, iStart + i))
iMaxQtyAvail = iMaxQtyAvail + Int(Me.List2.Column(iColUsed, iStart + i))
'Debug.Print "List Row: " & i2 & vbTab & "Qty: " & myarray(i2, 1)
i2 = i2 + 1
End If
End If
Next i
If iMaxQtyAvail < Qty Then
MsgBox "All rows combined only have a quantity of: " & iMaxQtyAvail & vbCrLf & "You asked for quantity of : " & Qty, vbOKOnly, "Insufficient Quantity Available"
GoTo End_Here
End If
myarray = BubbleSrt(myarray, True) ' Sort my Array by Quantity
' For i = 0 To UBound(myarray) ' List what the Array looks like after sorting.
' Debug.Print "Array: " & i & vbTab & myarray(i, 0) & " - " & myarray(i, 1)
' Next i
iQty = Qty
iReserved = 0
For i = 0 To Me.List2.ListCount 'Deselect ALL rows in Listbox - in case someone already started....
List2.Selected(i) = False
Next i
For i = 0 To UBound(myarray) ' Spin through the Array adding up rows to fulfill the desired quantity
'The following will search and possibly use part of a bin.
If myarray(i, 1) <> "" And myarray(i, 1) <= iQty Then ' Skip empty Array; check if <= Qty
If iReserved + myarray(i, 1) <= iQty Then
'Debug.Print "Row: " & myarray(iStart + i, 0) & vbTab & "Qty: " & myarray(iStart + i, 1)
List2.Selected(myarray(i, 0)) = True ' Select this row in Listbox
iReserved = iReserved + myarray(i, 1) ' Keep track of total reserved so far
If iReserved = iQty Then ' If just the right number, get outta here!
'Me.txtReserved = iReserved
GoTo End_Here
End If
Else ' Need to Adjust
' Not so simple. Need to see if can deselect a prior selected row and keep this row to arrive at total.
'Debug.Print "Need to Adjust; Qty Required / Current Reserved + ListItem = " & Qty & " / " & iReserved + myarray(iStart + i, 1)
iAddRow = i ' Save the row with the qty that would put us over the limit.
For i2 = iStart + i To 1 Step -1 ' Walk backwards so we deselect largest qty.
If ((iReserved + myarray(iAddRow, 1)) - myarray(i2, 1)) = iQty Then
' Found the right combination. Deselect this row, and select the row from earlier
'Debug.Print "Swap Rows"
List2.Selected(myarray(i2, 0)) = False ' Unselect this row in Listbox
List2.Selected(myarray(iAddRow, 0)) = True ' Select this row in Listbox
iReserved = iReserved + myarray(iAddRow, 1) - myarray(i2, 1) ' Count Total Reserved
'Me.txtReserved = iReserved
GoTo End_Here
End If
Next i2
' Yikes! I don't frrl like coding to handle deselecting some combination of 2 or more!!!
MsgBox "Qty Needed = " & Qty & vbCrLf & "Qty selected = " & iReserved & vbCrLf & vbCrLf & "Please manually select/deselect to obtain desired quantity", vbOKOnly, "Manually Select Quantity"
GoTo End_Here
End If
End If
Next i
If iQty > iReserved Then
MsgBox "Unable to find sufficient part quantity!", vbOKOnly, "Not Enough Parts"
'Deselect ALL
For i = 0 To Me.List2.ListCount
List2.Selected(i) = False
Next i
End If
End_Here:
'Me.txtQty = Me.txtQty + 1
End Function
Public Function BubbleSrt(ArrayIn As Variant, Ascending As Boolean)
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
Dim SrtTemp0 As Variant
Dim SrtTemp1 As Variant
If Ascending = True Then
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i, 1) > ArrayIn(j, 1) Then
SrtTemp0 = ArrayIn(j, 0)
SrtTemp1 = ArrayIn(j, 1)
ArrayIn(j, 0) = ArrayIn(i, 0)
ArrayIn(j, 1) = ArrayIn(i, 1)
ArrayIn(i, 0) = SrtTemp0
ArrayIn(i, 1) = SrtTemp1
End If
Next j
Next i
Else
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) < ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
End If
BubbleSrt = ArrayIn
End Function