Sub BarCut2()
Dim Rng As Range, sav As Variant, MyData As Variant, ctr(1 To 9999) As Long, bl As Double, ic As Double
Dim i As Long, j As Long, str1 As String, bool As Boolean, bn As Long, r As Long, barnum As Long
Dim bars As Variant, barqty As Long, itemqty As Long, dic As Object
Set Rng = Range("A2:D" & Cells(Rows.Count, "A").End(xlUp).Row)
sav = Rng.Value
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add2 Key:=Range("C2"), Order:=xlDescending
.SetRange Rng
.Header = xlNo
.Apply
End With
MyData = Rng.Value
Rng.Value = sav
barnum = 1
Range("H:I").ClearContents
Set dic = CreateObject("Scripting.Dictionary")
itemqty = WorksheetFunction.Sum(Range("B2:B1000"))
barqty = WorksheetFunction.Sum(Range("E2:E1000"))
ic = Range("D2").Value
Range("H1").Value = "Results"
Range("I1").Value = "Length used"
bars = Range("E2:F" & Range("E999").End(xlUp).Row).Value
Do While itemqty > 0 And barqty > 0
For i = 1 To UBound(bars)
If bars(i, 1) > 0 Then
bl = bars(i, 2)
Exit For
End If
Next i
barused = 0
Erase ctr
bool = False
Do While bl > 0
For j = 1 To UBound(MyData)
If MyData(j, 2) > 0 And MyData(j, 3) <= bl Then
ctr(j) = ctr(j) + 1
bl = bl - MyData(j, 3) - ic
barused = barused + MyData(j, 3) + ic
MyData(j, 2) = MyData(j, 2) - 1
bool = True
itemqty = itemqty - 1
Exit For
End If
Next j
If j > UBound(MyData) Then Exit Do
Loop
If bool Then
'str1 = "Bar " & barnum & ": "
For i = UBound(bars) To 1 Step -1
If bars(i, 2) > barused - ic Then
bars(i, 1) = bars(i, 1) - 1
barqty = barqty - 1
Range("I100").End(xlUp).Offset(1).Value = bars(i, 2)
bl = bars(i, 2) - barused
str1 = "Bar " & bars(i, 2) & ": "
Exit For
End If
Next i
For j = 1 To UBound(MyData)
If ctr(j) > 0 Then str1 = str1 & ctr(j) & " X " & MyData(j, 1) & ", "
Next j
str1 = str1 & "Leftover: " & bl
'Range("H100").End(xlUp).Offset(1).Value = str1
dic(str1) = dic(str1) + 1
barnum = barnum + 1
End If
Loop
j = 2
For Each x In dic
Cells(j, "H") = dic(x) & " copies of: " & x
j = j + 1
Next x
bool = False
str1 = "Not made: "
For i = 1 To UBound(MyData)
If MyData(i, 2) > 0 Then
bool = True
str1 = str1 & MyData(i, 1) & " X " & MyData(i, 2) & ", "
End If
Next i
If bool Then Cells(j + 2, "H") = Left(str1, Len(str1) - 2)
End Sub
