I got this program from online and I need to modify like below. seeking VBA coder help on this,
Currently program output is listed in "cutlist worksheet" against each Drum A, B, C etc according to its value instead I want to assign Drum A, B, C as applicable against respective value in C column in "input parameters" sheet itself. see below snap and codes
Current input as below:
current output as below:
program chose cut lengths of each drum and listed as below
Expected output as below in input sheet:
Sub Button1_Click()
Dim Cablelen() As Variant
Dim Cablelen2 As Variant
Dim Drumlen() As Variant
Dim Drumlen2() As Variant
Dim wastage(50) As Variant
Dim wastage2(50) As Variant
Dim multiarray(2, 50, 100) As Variant 'allows for 1000 different cut schedules on a maximum of 50 drums having a maximum number of cuts of 1000 per drum
Dim multiarray2(2, 50, 100) As Variant 'allows for 1000 different cut schedules on a maximum of 50 drums having a maximum number of cuts of 1000 per drum
Dim residual(2) As Variant
Dim cableammount As Variant
Dim drumammount As Variant
Dim drumnumber As Variant
Erase Cablelen()
Erase Drumlen()
Erase Drumlen2()
Erase multiarray()
Erase multiarray2()
Erase residual()
'check if more cable is specified than on drums
test1 = Range("I7").Value
If test1 < 0 Then
MsgBox "More cable required than allowed for on drums"
Exit Sub
End If
'fill cable length and drum length arrays
test1 = 1
counter = 0
Do Until test1 = ""
counter = counter + 1 'counter to index array and determine the ammount of cable lengths
test1 = Range("B" & CStr(counter + 4)) 'column B has values from B5
Loop
cableammount = counter - 1 'do while loop runs one more time than the ammount of cables as it needs to identify epty cell
Cablelen() = Application.Transpose(Range("B5:B" & CStr(cableammount + 5)))
test1 = 1 'reset the test condition and counter
counter = 0
Do Until test1 = ""
counter = counter + 1 'counter to index array and determine the ammount of cable lengths
test1 = Range("E" & CStr(counter + 4)) 'column B has values from E5
Loop
drumammount = counter - 1
Drumlen() = Application.Transpose(Range("E5:E" & CStr(drumammount + 5)))
Cablelen2 = Resample(Cablelen) 'randomises the cable array to give out
'assign cutlist to drum
residual(2) = -1000
For Z = 1 To 100000
Erase multiarray()
maxlengthsondrum = 0
Cablelen2 = Resample(Cablelen) 'randomises the cable array to give out
For drumnumber = 1 To drumammount - 1
exittest = 1
Calculation = 0
i = 0 'integer for keeping count
n = 0 'interger for array numbering
Do Until exittest = 2
i = i + 1
If Cablelen2(i) > 0 Then
If Calculation + Cablelen2(i) <= Drumlen(drumnumber) Then
n = n + 1
Calculation = Calculation + Cablelen2(i)
multiarray(1, drumnumber, n) = Cablelen2(i)
Cablelen2(i) = 0
If maxlengthsondrum < n Then
maxlengthsondrum = n
End If
End If
End If
wastage(drumnumber) = CInt(Drumlen(drumnumber)) - Calculation
If i = cableammount + 1 Then 'exit condition once all cables have been placed and no other fitting cable length is found
exittest = 2
End If
Loop
Next drumnumber
drumnumber = drumammount 'last iteration
exittest = 1
Calculation = 0
i = 0 'integer for keeping count
n = 0 'interger for array numbering
Do Until exittest = 2
i = i + 1
If Cablelen2(i) > 0 Then
n = n + 1
Calculation = Calculation + Cablelen2(i)
multiarray(1, drumnumber, n) = Cablelen2(i)
Cablelen2(i) = 0
If maxlengthsondrum < n Then
maxlengthsondrum = n
End If
End If
If i = cableammount + 1 Then 'exit condition once all cables have been placed and no other fitting cable length is found
exittest = 2
End If
Loop
residual(1) = Drumlen(drumnumber) - Calculation
If residual(1) > residual(2) Then 'finding the combination with the most amount of cable left on the last drum
maxlengthsondrum2 = maxlengthsondrum
Erase wastage2()
Erase multiarray2()
For xx = 1 To drumammount - 1
wastage2(xx) = wastage(xx)
Next xx
For a = 1 To 50
For b = 1 To 100
multiarray2(2, a, b) = multiarray(1, a, b) 'assigning the option to second multi array
Next b
Next a
residual(2) = residual(1)
wastage2(drumammount) = residual(2)
End If
Next Z
Worksheets("Cutlist").Range("A5:Z100").Clear
Worksheets("Cutlist").Range("E2") = residual(2)
For letter = 1 To drumammount
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(4)).Value = "Drum " & CStr(Chr(letter + 64))
'maxlengthsondrum2
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(maxlengthsondrum2 + 5)).Value = "Total"
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(maxlengthsondrum2 + 6)).Value = Drumlen(letter) - wastage2(letter)
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(maxlengthsondrum2 + 8)).Value = "Wastage on drum"
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(maxlengthsondrum2 + 9)).Value = wastage2(letter)
'Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(maxlengthsondrum2 + 6)).Borders (xlEdgeBottom)
For Count = 1 To maxlengthsondrum2
Worksheets("Cutlist").Range(Chr(letter + 64) & CStr(Count + 4)).Value = multiarray2(2, letter, Count)
Next Count
Next letter
If residual(2) < 0 Then
MsgBox "Could not find a solution that fits on the ammount of cable rolls! an additional " & CStr(residual(2)) & " m cable is required"
End If
End Sub
Function Resample(data_vector() As Variant) As Variant() 'sampled shuffling code from stackoverflow
Dim shuffled_vector() As Variant
shuffled_vector = data_vector
Dim i As Long
For i = UBound(shuffled_vector) To LBound(shuffled_vector) Step -1
Dim t As Variant
t = shuffled_vector(i)
Dim j As Long
j = Application.RandBetween(LBound(shuffled_vector), UBound(shuffled_vector))
shuffled_vector(i) = shuffled_vector(j)
shuffled_vector(j) = t
Next i
Resample = shuffled_vector
End Function