Sub ComputeStock()
Dim CutArr() As Double, DetStk() As Variant, Waste As Double, dStk() As Variant, pStk() As Variant
Dim CLastEntry As Integer, CRng As Range, ArCnt As Integer, StkLen() As Variant, DRng As Range
Dim Rng As Range, Cnter As Integer, Temp As Double, Temp2 As Double, rInpStk As Range
Dim lRowCount As Long, i As Long, j As Long, k As Long, rInputCuts As Range, cell As Range
Dim TotStk As Double, TmpStk As Double, rLastEntry As Range, AllZero As Boolean
Dim MinCut As Double, TotCut As Double, sMsg As String, sTtl As String, FlagIt As Boolean
Dim Temp3 As Double, Temp4 As Double, t As Integer, TempArr() As Variant, TempArr2() As Variant
'number of pieces to be cut in A2:A & whatever
'lengths of pieces to be cut in B2:B & whatever
'stock lengths available in C2:C & whatever
'number of pieces of stock lengths in D2:D & whatever
'sheet name is "wshCuts"
'http://dailydoseofexcel.com/archives/author/****-kusleika/page/120/
'POSTED ON SEPTEMBER 12, 2005 BY **** KUSLEIKA
'****Code adjusted for multiple stock lengths and varied stock pieces
With Sheets("wshCuts")
Set rLastEntry = .Range("A" & .Rows.Count).End(xlUp)
Set rInpStk = .Range("C" & 2)
End With
'Make sure cuts have been entered
If rLastEntry.Address = "$A$1" Then
Exit Sub
Else
Set rInputCuts = Sheets("wshCuts").Range("A2", rLastEntry.Address).Resize(, 2)
lRowCount = rInputCuts.Rows.Count
End If
'Check for non-numeric data and negative numbers
For Each cell In rInputCuts.Cells
If Not IsNumeric(cell.Value) Then
MsgBox "Your selected range contains non-numeric data"
Exit Sub
End If
If cell.Value < 0 Then
MsgBox "All values must be positive"
Exit Sub
End If
Next cell
'Make sure stock length was entered
If IsEmpty(rInpStk.Value) Or Not IsNumeric(rInpStk.Value) Or rInpStk.Value <= 0 Then
MsgBox "Stock length must be a positive number"
Exit Sub
Else ' set range of stock lengths
With Sheets("wshCuts")
CLastEntry = .Range("C" & .Rows.Count).End(xlUp).Row
Set CRng = .Range(.Cells(2, "C"), .Cells(CLastEntry, "C"))
Set DRng = .Range(.Cells(2, "D"), .Cells(CLastEntry, "D"))
End With
End If
'load rng to dStk stock array of board lengths
For Each Rng In CRng
Cnter = Cnter + 1
ReDim Preserve dStk(Cnter)
dStk(Cnter - 1) = Rng.Value
Next Rng
'load rng to pStk stock piece array
Cnter = 0
For Each Rng In DRng
Cnter = Cnter + 1
ReDim Preserve pStk(Cnter)
pStk(Cnter - 1) = Rng.Value
Next Rng
'Sort descending stock length & stock piece arrays
For i = 0 To UBound(dStk) - 1
For j = i + 1 To UBound(dStk)
If dStk(i) < dStk(j) Then
Temp = dStk(i) 'small
Temp2 = dStk(j) 'large
Temp3 = pStk(i) 'small
Temp4 = pStk(j) 'large
dStk(i) = Temp2
dStk(j) = Temp
pStk(i) = Temp4
pStk(j) = Temp3
End If
Next j
Next i
'Fill array with cuts
ReDim CutArr(lRowCount - 1, 1)
For i = 0 To UBound(CutArr, 1)
For j = 0 To UBound(CutArr, 2)
CutArr(i, j) = rInputCuts.Cells(i + 1, j + 1)
Next j
Next i
'Sort Cut array descending on cut length
For i = 0 To UBound(CutArr, 1) - 1
For j = i + 1 To UBound(CutArr, 1)
If CutArr(i, 1) < CutArr(j, 1) Then
Temp = CutArr(j, 0)
Temp2 = CutArr(j, 1)
CutArr(j, 0) = CutArr(i, 0)
CutArr(j, 1) = CutArr(i, 1)
CutArr(i, 0) = Temp
CutArr(i, 1) = Temp2
End If
Next j
Next i
'Make sure all cuts can be made with stock length
If CutArr(0, 1) > dStk(LBound(dStk)) Then
MsgBox "At least one cut is greater than the stock length."
Exit Sub
End If
'Initialize variables
MinCut = CutArr(UBound(CutArr), 1)
'Get ArCnt for stock length array
'remove stock lengths that are too short for cut lengths from array
For ArCnt = UBound(dStk) - 1 To LBound(dStk) Step -1
If MinCut <= dStk(ArCnt) Then
Exit For
Else
ReDim Preserve dStk(UBound(dStk) - 1)
ReDim Preserve pStk(UBound(pStk) - 1)
End If
Next ArCnt
'StkLen array stores stock array outputs
ReDim StkLen(1)
StkLen(0) = dStk(ArCnt)
TotCut = 1 'set > 0 to start loop, TotCut is
'recalced within loop
TmpStk = 0
i = 0
k = 0
'TotCut is sum of first dimensions in array
Do While TotCut > 0
'MinCut is smallest 2nd dimension where 1st
'dimension is > 0
Do While TmpStk >= MinCut
If CutArr(i, 1) <= TmpStk And CutArr(i, 0) > 0 Then
'Reduce current stock length by cut length
TmpStk = TmpStk - CutArr(i, 1)
'Reduce number of current cut by 1
CutArr(i, 0) = CutArr(i, 0) - 1
'Store current cut length
ReDim Preserve DetStk(1, k)
DetStk(0, k) = TotStk
DetStk(1, k) = CutArr(i, 1)
'store stock length
ReDim Preserve StkLen(k)
StkLen(k) = dStk(ArCnt)
k = k + 1
Else
'Move to next cut length
i = i + 1
End If
'Reset MinCut
AllZero = True
For j = LBound(CutArr) To UBound(CutArr)
If CutArr(j, 0) > 0 Then
MinCut = CutArr(j, 1)
AllZero = False
End If
Next j
'If there are no cut pieces remaining, get out
If AllZero Then
Exit Do
End If
Loop
FlagIt = False
'if waste exists
If TmpStk <> 0 Then
'check if waste is large enough for another cut length
If TmpStk <> dStk(ArCnt) Then
Waste = Waste + TmpStk
ReDim Preserve DetStk(1, k)
DetStk(0, k) = TotStk
DetStk(1, k) = TmpStk & " Waste"
ReDim Preserve StkLen(k)
StkLen(k) = dStk(ArCnt)
k = k + 1
Else
'use stock piece for another cut
FlagIt = True
End If
End If
'if out of stock move to next stock length and remove item from stock array
If pStk(ArCnt) = 0 Then
ReDim TempArr2(UBound(dStk) - 1)
ReDim TempArr(UBound(pStk) - 1)
For t = LBound(dStk) To UBound(dStk) - 1
If t <> ArCnt Then
TempArr(t) = dStk(t)
TempArr2(t) = pStk(t)
End If
Next t
dStk = TempArr
pStk = TempArr2
ArCnt = ArCnt - 1
If ArCnt < 0 Then
MsgBox "Not enough Stock to make all Pieces at Cut Lengths!!!"
Exit Sub
End If
End If
'Get ArCnt for stock length array
For ArCnt = UBound(dStk) - 1 To LBound(dStk) Step -1
If MinCut <= dStk(ArCnt) Then
Exit For
End If
Next ArCnt
'reduce stock amt by 1, reset TmpStk
'add one to TotStk only if stock piece not being used for another cut length
pStk(ArCnt) = pStk(ArCnt) - 1
TmpStk = dStk(ArCnt)
If Not FlagIt Then
TotStk = TotStk + 1
End If
'Reset i to row of largest 2nd dimension whose
'1st dimension Is Not zero
For j = UBound(CutArr) To LBound(CutArr) Step -1
If CutArr(j, 0) <> 0 Then
i = j
End If
Next j
'Reset TotCut to sum of all 1st
'dimensions
TotCut = 0
For j = LBound(CutArr) To UBound(CutArr)
TotCut = TotCut + CutArr(j, 0)
Next j
Loop
'Output totals to a message box
sTtl = "Total Boards = " & TotStk - 1
sMsg = "Board No." & vbTab & "Stock Length" & vbTab & "Cut Length" & vbCrLf
For k = LBound(DetStk, 2) To UBound(DetStk, 2)
sMsg = sMsg & DetStk(0, k) & vbTab & vbTab & StkLen(k) & vbTab & vbTab _
& DetStk(1, k) & vbCrLf
Next k
MsgBox sMsg & vbCrLf & "Total Waste: " & Waste, vbOKOnly, sTtl
End Sub
