ncarnevale1
New Member
- Joined
- Jan 15, 2021
- Messages
- 1
- Office Version
- 365
- Platform
- Windows
I managed to find this nice simple cut list optimizer macro that someone made. It was on another forum site, and I can't find the original post to save my life. Original file was called BoardFeet. I'm not that well versed in VBA code, but I'm trying to figure out a way to output the cut measurements on a separate sheet instead of a message box. How would I go about doing that? Code attached below.
Excel Formula:
Sub ComputeStock()
Dim CutArr() As Double, DetStk() As Double
Dim R As Long
Dim lRowCount As Long
Dim i As Long, j As Long, k As Long
Dim temp As Double, temp2 As Double
Dim TotStk As Double, TmpStk As Double
Dim MinCut As Double, TotCut As Double
Dim dStk As Double
Dim rInpStk As Range
Dim rInputCuts As Range
Dim rLastEntry As Range
Dim AllZero As Boolean
Dim sMsg As String, sTtl As String
Dim cell As Range
Set rLastEntry = wshCuts.Range("A" & wshCuts.Rows.Count).End(xlUp)
Set rInpStk = wshCuts.Range("InpStock")
'Make sure cuts have been entered
If rLastEntry.Address = "$A$1" Then
Exit Sub
Else
Set rInputCuts = 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 lenght 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
dStk = rInpStk.Value
End If
ReDim CutArr(lRowCount - 1, 1)
'Fill array with cuts
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 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 lenght
If CutArr(0, 1) > dStk Then
MsgBox "At least one cut is greater than the stock length."
Exit Sub
End If
'Initialize variables
MinCut = CutArr(UBound(CutArr), 1)
TmpStk = dStk
TotCut = 1 'set > 0 to start loop, TotCut is
'recalced within loop
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 + 1
DetStk(1, k) = CutArr(i, 1)
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
'Reset TmpStk and add one to TotStk
TmpStk = dStk
TotStk = TotStk + 1
'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 stock at " & dStk & " = " & TotStk
sMsg = "Board No." & vbTab & "Cut Lenght" & vbCrLf
For k = LBound(DetStk, 2) To UBound(DetStk, 2)
sMsg = sMsg & DetStk(0, k) & vbTab & vbTab _
& DetStk(1, k) & vbCrLf
Next k
MsgBox sMsg, vbOKOnly, sTtl
End Sub
