Optimized Cut List

ncarnevale1

New Member
Joined
Jan 15, 2021
Messages
1
Office Version
  1. 365
Platform
  1. 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
 

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

StephenCrump

MrExcel MVP
Joined
Sep 18, 2013
Messages
4,119
Office Version
  1. 365
Platform
  1. Windows
Welcome to the Forum!

VBA Code:
'Replace
    '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
'with ...
    Worksheets("Sheet1").Range("A1").Resize(2, 1 + UBound(DetStk, 2)).Value = DetStk

This will dump the array to a range starting in Sheet1!A1 - please adjust to your requirements.

(My code line is a bit sloppy - it should allow for both UBound and LBound. But in that respect it matches the existing code. This is hard-coded for zero Ubounds, and will crash in an Option Base 1 environment).
 

Watch MrExcel Video

Forum statistics

Threads
1,127,539
Messages
5,625,404
Members
416,100
Latest member
lirongr1996

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top