A few years ago, a friend sent me this program. It is written in VBA for Microsoft Excel (shameful, I know, sorry). His focus was optimizing cuts in sheets of plywood. It should be possible to pick out the algorithm. It draws pretty pictures of the cuts as well.
You enter a list of shapes in a few columns and a list of boards available in another few columns.
Private Sub cmdCrunch_Click()
Dim PcLengthCol, PcWidthCol, PcStatCol, StLengthCol, StWidthCol, S
+tStatCol, KerfCol, KerfRow, PcIDCol, StIDCol, PcQntCol, StQntCol As I
+nteger
Dim MaxYDraw, YDrawScale, XDim, YDim, DrawXStart, DrawYStart, MaxS
+tLength, MaxStWidth, SubXStart, SubYStart As Integer
Dim i, j, k, ArraySize, StartRow, PcListSize, StListSize, Row As I
+nteger
Dim YieldRow, YeildCol, SubYeildCol As Integer
Dim UsedArea, StockArea, Yeild, RowHeight As Single
Dim Stock(100, 4), Pieces(100, 5) As Variant
Dim Length, Width, Kerf, LRemain, LWidth As Single
Dim AutoPcID As Boolean
Dim ID As String
StartRow = 5
ArraySize = 100
PcIDCol = 1
PcLengthCol = 2
PcWidthCol = 3
PcQntCol = 4
PcStatCol = 5
StIDCol = 6
StLengthCol = 7
StWidthCol = 8
StQntCol = 9
StStatCol = 10
KerfRow = 4
KerfCol = 13
YeildRow = 5
YeildCol = 13
MaxYDraw = 300
DrawXStart = 390
DrawYStart = 100
MaxStWidth = 0
UsedArea = 0
StockArea = 0
AutoPcID = True
AutoStID = True
StListSize = 0
PcListSize = 0
SubYeildCol = 11
For Each sh In Worksheets(1).Shapes 'clears graphics
'if cell comments are inserted in worksheets, this loop will fail.
If sh.Type <> msoOLEControlObject Then
sh.Select
Selection.Delete
End If
i = i + 1
Next
Worksheets(1).Range("E6:F106").Select 'clears previous results
Selection.ClearContents
Worksheets(1).Range("J6:K106").Select
Selection.ClearContents
Worksheets(1).Range("M5").Select
Selection.ClearContents
Kerf = Worksheets(1).Cells(KerfRow, KerfCol).Value 'Reads Kerf val
+ue
If Kerf = "" Then
Msg = MsgBox("No kerf value was entered, assume 1/8 inch?", 4,
+ "Whoooa!")
If Msg = vbYes Then
Kerf = 0.125
Worksheets(1).Cells(KerfRow, KerfCol) = 0.125
Else
Worksheets(1).Range("L4").Select
End
End If
End If
If (Kerf > 0.25) And (Kerf < 3) Then
Msg = MsgBox("Kerf is very large, proceed?", 4, "Whoooa!")
If Msg <> vbYes Then
Worksheets(1).Range("L4").Select
End
End If
End If
If Kerf >= 3 Then
Msg = MsgBox("What the?! Kerf must be less than 3 inches!", 0,
+ "Whoooa!")
Worksheets(1).Range("L4").Select
End
End If
If Worksheets(1).Cells(StartRow + 1, PcIDCol) <> "" Then 'Checks i
+f user inputted ID labels
AutoPcID = False
End If
i = 1 'Determines size of Stock list, IDs the items
Do Until i = ArraySize
Length = Worksheets(1).Cells(StartRow + i, StLengthCol).Value
+'Reads length
Width = Worksheets(1).Cells(StartRow + i, StWidthCol).Value 'R
+ead Width
If (Length = "") Or (Width = "") Then 'If blank length value,
+then exit
If i = 1 Then
Msg = MsgBox("No Stock values entered or blank dimensi
+on value found at begining of Stock list!", vbCritical, "Whoooa!")
End
End If
Exit Do
End If
Quantity = Worksheets(1).Cells(StartRow + i, StQntCol).Value
If Quantity = "" Then 'if no Quantity amount entered, assume u
+nity
Quantity = 1
End If
For j = (StListSize + 1) To (StListSize + Quantity)
Stock(j, 1) = j 'ID
Stock(j, 2) = Length
Stock(j, 3) = Width
Stock(j, 4) = -1
Next j
StListSize = StListSize + Quantity 'Updates list size
i = i + 1
Loop
For i = 1 To StListSize 'Rewrites expanded Stock list
Worksheets(1).Cells(StartRow + i, StIDCol) = Stock(i, 1)
Worksheets(1).Cells(StartRow + i, StLengthCol) = Stock(i, 2)
Worksheets(1).Cells(StartRow + i, StWidthCol) = Stock(i, 3)
Worksheets(1).Cells(StartRow + i, StQntCol) = 1
Next i
i = 1 'Determines size of Pieces list, IDs the items
Do Until i = ArraySize
Length = Worksheets(1).Cells(StartRow + i, PcLengthCol).Value
Width = Worksheets(1).Cells(StartRow + i, PcWidthCol).Value
If (Length = "") Or (Width = "") Then 'If blank length value,
+then exit
If i = 1 Then
Msg = MsgBox("No Piece values entered or blank dimensi
+on value found at begining of Pieces list!", vbCritical, "Whoooa!")
End
End If
Exit Do
End If
If AutoPcID = False Then
ID = Worksheets(1).Cells(StartRow + i, PcIDCol) 'Reads Use
+r ID label
Else
ID = i 'Auto assigns ID
End If
Quantity = Worksheets(1).Cells(StartRow + i, PcQntCol).Value
If Quantity = "" Then 'if no Quantity amount entered, assume u
+nity
Quantity = 1
End If
For j = (PcListSize + 1) To (PcListSize + Quantity)
Pieces(j, 1) = ID
Pieces(j, 2) = Length
Pieces(j, 3) = Width
Pieces(j, 4) = -1
Pieces(j, 5) = -1
Next j
PcListSize = PcListSize + Quantity
i = i + 1
Loop
For i = 1 To PcListSize
Worksheets(1).Cells(StartRow + i, PcIDCol) = Pieces(i, 1)
Worksheets(1).Cells(StartRow + i, PcLengthCol) = Pieces(i, 2)
Worksheets(1).Cells(StartRow + i, PcWidthCol) = Pieces(i, 3)
Worksheets(1).Cells(StartRow + i, PcQntCol) = 1
Next i
Range("A6:D105").Select 'Sorts Pieces by Length then by Width
ActiveWindow.ScrollRow = 1
Selection.Sort Key1:=Range("B6"), Order1:=xlDescending, Key2:=Rang
+e("C6") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, Match
+Case:= _
False, Orientation:=xlTopToBottom
For i = 1 To PcListSize 'Reads Pieces into array
Pieces(i, 1) = Worksheets(1).Cells(StartRow + i, PcIDCol).Valu
+e 'ID label
Pieces(i, 2) = Worksheets(1).Cells(StartRow + i, PcLengthCol).
+Value 'Length
Pieces(i, 3) = Worksheets(1).Cells(StartRow + i, PcWidthCol).V
+alue 'Width
Pieces(i, 4) = -1 'Stock Status
Pieces(i, 5) = -1 'Row Status
Next i
Range("F6:I105").Select 'Sorts Stock by Length then by Width
ActiveWindow.ScrollRow = 1
Selection.Sort Key1:=Range("G6"), Order1:=xlDescending, Key2:=Rang
+e("H6") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, Match
+Case:= _
False, Orientation:=xlTopToBottom
For i = 1 To StListSize 'Reads Stock into array
Stock(i, 1) = Worksheets(1).Cells(StartRow + i, StIDCol).Value
+ 'ID label
Stock(i, 2) = Worksheets(1).Cells(StartRow + i, StLengthCol).V
+alue + Kerf 'Length
Stock(i, 3) = Worksheets(1).Cells(StartRow + i, StWidthCol).Va
+lue + Kerf 'Width
Stock(i, 4) = -1 'Status
If Stock(i, 3) > MaxStWidth Then MaxStWidth = Stock(i, 3)
Next i
Worksheets(1).Range("A1").Select
For i = 1 To StListSize 'Optimizing Routine
LRemain = Stock(i, 2)
Row = 0
For j = 1 To PcListSize 'for each Piece
WRemain = Stock(i, 3)
If (Pieces(j, 4) = -1) And (Pieces(j, 2) + Kerf <= LRemain
+) And (Pieces(j, 3) + Kerf <= WRemain) Then 'if Row starter Piece is
+unused and fits
Row = Row + 1 'Add new Row
LRemain = LRemain - Pieces(j, 2) - Kerf 'evaluate rema
+ining Stock Length
WRemain = WRemain - Pieces(j, 3) - Kerf ' evaluate rem
+aining Row Width
Pieces(j, 4) = Stock(i, 1) 'Labels Piece with Stock ID
Pieces(j, 5) = Row ' Labels Piece with Row on Stock
For k = (j + 1) To PcListSize
If (Pieces(k, 4) = -1) And (Pieces(k, 3) + Kerf <=
+ WRemain) Then 'Unused and fits
WRemain = WRemain - Pieces(k, 3) - Kerf ' eval
+uate remaining Row Width
Pieces(k, 4) = Stock(i, 1) 'Labels Piece with
+Stock ID
Pieces(k, 5) = Row ' Labels Piece with Row on
+Stock
End If
Next k
End If
Next j
Stock(i, 4) = Row 'how many rows of fitted Pieces per sheet of
+ stock
Next i
For i = 1 To PcListSize 'writes Piece Status
If Pieces(i, 4) = -1 Then
Worksheets(1).Cells(StartRow + i, PcStatCol) = "Not Cut"
Else
Worksheets(1).Cells(StartRow + i, PcStatCol) = "Cut"
End If
Next i
For i = 1 To StListSize 'writes Stock Status
If Stock(i, 4) = 0 Then
Worksheets(1).Cells(StartRow + i, StStatCol) = "Not Used"
Else
Worksheets(1).Cells(StartRow + i, StStatCol) = "Used"
End If
Next i
For i = 1 To PcListSize - 1 'Checks for large differences in Piece
+ lengths and tags them
If (Pieces(i + 1, 2) / Pieces(i, 2) < 0.8) And (Pieces(i + 1,
+4) <> -1) And (Pieces(i, 4) <> -1) Then
Msg = MsgBox("Large differences in length of Pieces " & Pi
+eces(i, 1) & " and " & Pieces(i + 1, 1) & " may result in inefficient
+ layout", 0, "Warning Only")
Worksheets(1).Cells(StartRow + i, PcStatCol) = "+ Cut +"
Worksheets(1).Cells(StartRow + i + 1, PcStatCol) = "+ Cut
++"
End If
Next i
For j = 1 To StListSize 'calculates yeild for each Stock item
UsedArea = 0
StockArea = (Stock(j, 2) - Kerf) * (Stock(j, 3) - Kerf)
For i = 1 To PcListSize
If Pieces(i, 4) = j Then UsedArea = UsedArea + Pieces(i, 2
+) * Pieces(i, 3)
Next i
Yeild = UsedArea / StockArea
Worksheets(1).Cells(StartRow + j, SubYeildCol) = Yeild
Next j
UsedArea = 0 'calculates overall yeild
StockArea = 0
For i = 1 To PcListSize
If Pieces(i, 4) <> -1 Then UsedArea = UsedArea + Pieces(i, 2)
+* Pieces(i, 3)
Next i
For i = 1 To StListSize
If Stock(i, 4) <> 0 Then StockArea = StockArea + Stock(i, 2) *
+ Stock(i, 3)
Next i
If StockArea = 0 Then
Msg = MsgBox("Pieces too large for Stock", 0, "Whoooa!")
End
End If
Yeild = UsedArea / StockArea
Worksheets(1).Cells(YeildRow, YeildCol) = Yeild
MaxStLength = Stock(1, 2) 'Scales drawing size
YDrawScale = Int(MaxYDraw / MaxStLength)
For i = 1 To StListSize 'Drawing routine
YDim = Stock(i, 2) * YDrawScale
XDim = Stock(i, 3) * YDrawScale
SubYStart = DrawYStart
SubXStart = DrawXStart
ActiveSheet.Shapes.AddShape(msoShapeRectangle, DrawXStart, Dra
+wYStart, XDim, YDim).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, Draw
+XStart + XDim / 2, DrawYStart - 15, 0#, 0#).Select
Selection.Characters.Text = Str(Stock(i, 1))
For k = 1 To Stock(i, 4) 'For each row in Stock
RowHeight = 0
SubXStart = DrawXStart 'Start X at beginning of Row
For j = 1 To PcListSize 'For all Pieces
If Pieces(j, 4) = i And Pieces(j, 5) = k Then 'if Piec
+e is in Stock and in Row
YDim = Pieces(j, 2) * YDrawScale 'Scale Piece size
If YDim > RowHeight Then RowHeight = YDim
XDim = Pieces(j, 3) * YDrawScale
ActiveSheet.Shapes.AddShape(msoShapeRectangle, Sub
+XStart, SubYStart, XDim, YDim).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor =
+44
ActiveSheet.Shapes.AddLabel(msoTextOrientationHori
+zontal, SubXStart + XDim / 2 - 8, SubYStart + YDim / 2 - 5, 0#, 0#).S
+elect
Selection.Characters.Text = Pieces(j, 1)
SubXStart = SubXStart + XDim + Kerf * YDrawScale
End If
Next j
SubYStart = SubYStart + RowHeight + Kerf * YDrawScale
Next k
DrawXStart = DrawXStart + (Stock(i, 3) * YDrawScale) + 10
Next i
Worksheets(1).Range("A1").Activate
End Sub
Private Sub cmdReset_Click()
Proceed = MsgBox("This will clear all previous outputs! Proceed?",
+ 4, "Whoooa!")
If Proceed <> vbYes Then End
Worksheets(1).Range("E6:F106").Select
Selection.ClearContents
Worksheets(1).Range("J6:K106").Select
Selection.ClearContents
Worksheets(1).Range("M5").Select
Selection.ClearContents
Worksheets(1).Range("A1").Activate
For Each sh In Worksheets(1).Shapes 'clears graphics
If sh.Type <> msoOLEControlObject Then
sh.Select
Selection.Delete
End If
i = i + 1
Next
End Sub