Private Sub cmdCrunch_Click()
    Dim PcLengthCol, PcWidthCol, PcStatCol, StLengthCol, StWidthCol, StStatCol, KerfCol, KerfRow, PcIDCol, StIDCol, PcQntCol, StQntCol As Integer
    Dim MaxYDraw, YDrawScale, XDim, YDim, DrawXStart, DrawYStart, MaxStLength, MaxStWidth, SubXStart, SubYStart As Integer
    Dim i, j, k, ArraySize, StartRow, PcListSize, StListSize, Row As Integer
    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 value
    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 if 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 'Read Width
        If (Length = "") Or (Width = "") Then 'If blank length value, then exit
            If i = 1 Then
                Msg = MsgBox("No Stock values entered or blank dimension 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 unity
            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 dimension 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 User 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 unity
            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:=Range("C6") _
        , Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    For i = 1 To PcListSize 'Reads Pieces into array
        Pieces(i, 1) = Worksheets(1).Cells(StartRow + i, PcIDCol).Value 'ID label
        Pieces(i, 2) = Worksheets(1).Cells(StartRow + i, PcLengthCol).Value 'Length
        Pieces(i, 3) = Worksheets(1).Cells(StartRow + i, PcWidthCol).Value '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:=Range("H6") _
        , Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        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).Value + Kerf 'Length
        Stock(i, 3) = Worksheets(1).Cells(StartRow + i, StWidthCol).Value + 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 remaining Stock Length
                WRemain = WRemain - Pieces(j, 3) - Kerf ' evaluate remaining 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 ' evaluate 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 " & Pieces(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, DrawYStart, XDim, YDim).Select
        Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
        ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, DrawXStart + 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 Piece 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, SubXStart, SubYStart, XDim, YDim).Select
                    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 44
                    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, SubXStart + XDim / 2 - 8, SubYStart + YDim / 2 - 5, 0#, 0#).Select
                    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