Create batches based on set quantities and order by earliest date

Hello all,

I have a list of orders for skateboards with the model, date, and quantity for each order. Unfortunately, I can only make 25 skateboards a week. Is there a way I can take the data and create a production schedule with batches of 25 per model and rank them by earliest dates fist?

Thanks!

Ocdawg

Dear OCdawg:

First order first serve or you want to lump together the same model orders in order to optimize production?

Thanks for responding - I'd. Like to rank them by model.

Ocdawg

Dear Ocadawg:

I did this manually just to show if that would be a desirable output. I did realize that it should have started with model 33T because it has the oldest date. It would be taken into account on the real scheme.

Wow, that looks great. Is there a formula to do that?

Ocdawg

I will work on over the weekend...

Below please find the macro that will produce the output in TRIAL
I have included the workbook as well
Have a nice weekend!!

Set sh1 = Sheets("trial")
r1 = 3
r1min = 3
wl = 0
wek = 5
maxwl = 25
sh1.Cells(r1, "D") = "Week 1"
While sh1.Cells(r1, 1) <> ""
 lt = sh1.Cells(r1, "C")
 wl = wl + lt
 If wl > maxwl Then
   If lt - wl + maxwl > 0 Then sh1.Cells(r1, wek) = lt - wl + maxwl
   lt = wl - maxwl
   wek = wek + 1
   wl = lt
   If lt >= maxwl Then
     sh1.Cells(r1, wek) = maxwl
     wek = wek + 1
     lt = lt - maxwl
     wl = lt
   End If
 End If
  If lt > 0 Then sh1.Cells(r1, wek) = lt
  sh1.Cells(r1, "D") = "Week " & wek - 4
 r1 = r1 + 1
Wend

End Sub

Very nice!

You rock!

Ok mark it as solved if you are satisfied. It was a good brain challenge. Any time

Just a warning, it does take care of smaller orders but if you have an order over 80 it needs extra coding... your call

What is the extra coding?

Sub weekly()

Set sh1 = Sheets("trial")
r1 = 3
r1min = 3
wl = 0
wek = 5
maxwl = 25
sh1.Cells(r1, "D") = "Week 1"
While sh1.Cells(r1, 1) <> ""
 lt = sh1.Cells(r1, "C")
 wl = wl + lt
 If wl > maxwl Then
   If lt - wl + maxwl > 0 Then sh1.Cells(r1, wek) = lt - wl + maxwl
   lt = wl - maxwl
   wek = wek + 1
   wl = lt
   While lt >= maxwl
     sh1.Cells(r1, wek) = maxwl
     wek = wek + 1
     lt = lt - maxwl
     wl = lt
   Wend
 End If
  If lt > 0 Then sh1.Cells(r1, wek) = lt
  sh1.Cells(r1, "D") = "Week " & wek - 4
 r1 = r1 + 1
Wend

End Sub

With this change the macro can now handle big orders... give it a try..

What do I do after adding the code to a new macro? I hit run, but it only prints "Week 1" on the trial sheet. I'm on Excel 2007.

Thanks,

Ocdawg

I tried this improved macro with a lot size of 100 and it worked. It is writing to the SHEET "TRIAL". I dont see any command that is not compatible with your execl version. Please write if it does not work for you but send me your actual data sheet. It must start in row 3.

Sub weekly()

Set sh1 = Sheets("trial")
sh1.Range("d3:v40").ClearContents
r1 = 3
r1min = 3
wl = 0
wek = 5
maxwl = 25
sh1.Cells(r1, "D") = "Week 1"
While sh1.Cells(r1, 1) <> ""
  lt = sh1.Cells(r1, "C")
  wl = wl + lt
 
  While wl > maxwl
    If lt - wl + maxwl > 0 Then sh1.Cells(r1, wek) = lt - wl + maxwl
    lt = wl - maxwl
    wek = wek + 1
    wl = lt
  Wend
   
  If lt > 0 Then sh1.Cells(r1, wek) = lt
  sh1.Cells(r1, "D") = "Week " & wek - 4
  r1 = r1 + 1
Wend

End Sub

ot

Hello,

Perhaps I am not executing it properly. I've attached the file I am working with. It only prints "Week 1" on the Trial sheet.

Thanks!

Ocdawg

Try the attached.

Sub test()
    Dim a, b, i As Long, ttl As Long, n As Long, myWk As Long
    Const maxJob As Long = 25
    With Sheets("sheet1")
        a = Sheets("sheet1").[a3].CurrentRegion.Value
        ReDim b(1 To 10000, 1 To 4): myWk = 1: n = 1
        b(1, 1) = "Week" & myWk: VSortM a, 1, UBound(a, 1), 2
        For i = 1 To UBound(a, 1)
            If a(i, 3) <> 0 Then
                If ttl + a(i, 3) <= maxJob Then
                    n = n + 1
                    b(n, 2) = a(i, 1): b(n, 3) = a(i, 2): b(n, 4) = a(i, 3)
                    ttl = ttl + a(i, 3)
                    If ttl = maxJob Then
                        myWk = myWk + 1: n = n + 1
                        b(n, 1) = "Week" & myWk: ttl = 0
                    End If
                Else
                    n = n + 1
                    b(n, 2) = a(i, 1): b(n, 3) = a(i, 2)
                    b(n, 4) = maxJob - ttl: ttl = b(n, 4)
                    myWk = myWk + 1: n = n + 1
                    b(n, 1) = "Week" & myWk
                    a(i, 3) = a(i, 3) - ttl: ttl = 0: i = i - 1
                End If
            End If
        Next
        .Columns("f:j").ClearContents
        .[f2].Resize(n, 4) = b
    End With
End Sub

Sub VSortM(ary, LB, UB, ref)
    Dim i As Long, ii As Long, iii As Long, M, temp
    i = UB: ii = LB
    M = ary(Int((LB + UB) / 2), ref)
    Do While ii <= i
        Do While ary(ii, ref) < M: ii = ii + 1: Loop
        Do While ary(i, ref) > M: i = i - 1: Loop
        If ii <= i Then
            For iii = LBound(ary, 2) To UBound(ary, 2)
                temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
            Next
            i = i - 1: ii = ii + 1
        End If
    Loop
    If LB < i Then VSortM ary, LB, i, ref
    If ii < UB Then VSortM ary, ii, UB, ref
End Sub

Hi, I think I found the reason it was not working. Originally I had copied the data into TRIAL manually. Nevertheless, if you want to start in a clean worksheet, TRIAL, I added the necessary code. Data is to be in "SHEET1".

Sub weekly()
Set sh0 = ThisWorkbook.Sheets("sheet1")
Set sh1 = ThisWorkbook.Sheets("trial")
sh1.Cells.ClearContents
r1 = 3
r0 = r1
r1min = 3
wl = 0
wek = 5
maxwl = 25
sh1.Cells(r1, "D") = "Week 1"

While sh0.Cells(r0, 1) <> ""
  For j = 1 To 3
    sh1.Cells(r1, j) = sh0.Cells(r0, j)
  Next j
 lt = sh1.Cells(r1, "C")
 wl = wl + lt
 While wl > maxwl
   If lt - wl + maxwl > 0 Then sh1.Cells(r1, wek) = lt - wl + maxwl
   lt = wl - maxwl
   wek = wek + 1
   wl = lt
 Wend
 
  If lt > 0 Then sh1.Cells(r1, wek) = lt
  sh1.Cells(r1, "D") = "Week " & wek - 4
 r1 = r1 + 1
 r0 = r0 + 1
Wend

For c = 1 To wek - 4
  sh1.Cells(1, c + 4) = "W " & WorksheetFunction.Text(c, "00")
Next c

 sh1.Cells(3, 1).Select
 ActiveCell.CurrentRegion.EntireColumn.AutoFit
    
End Sub

You were right, that fixed it! I appreciate your help.

What code would I need to add if I wanted to add columns that list the customer, purchase order and sales order? See attached. Is there a way to have the data output into a vertical display?

Thanks so much.

Ocdawg

I changed the code to fit the 3 new fields.

Could you elaborate on the "vertical display"?
Please include the desired output format (just an small example) so the output can be formatted the way you want...

Check the VERTICAL tab. Is that what you mean by vertical. the ** is when the order is completed.

Yes, that is the vertical type layout. But it doesn't look like it's breaking into groups of 25.

Ocdawg

You are right. It was working but showing the wrong parameter. Take a look at it now...

Very cool!

What code would I add to bring it back to keeping the model groups together for batching?

Ocdawg

The easiest way is to sort the orders by MODEL and then by date so just add the red Highlighted line.

Sub weekly()
Set sh0 = ThisWorkbook.Sheets("sheet1")
Set sh1 = ThisWorkbook.Sheets("trial")
Set sh2 = ThisWorkbook.Sheets("vertical")
sh1.Cells.Delete
sh2.Cells.j

r1min = 3
r1 = 3
r0 = r1
r2 = 5
wl = 0

wek = 8
maxwl = 25
flds = 6
sh1.Cells(r1, "G") = "W 1"

While sh0.Cells(r0, 1) <> ""
  For j = 1 To flds
    sh1.Cells(r0, j) = sh0.Cells(r0, j)
    sh1.Cells(r0, j).Interior.Color = sh0.Cells(r0, j).Interior.Color
  Next j
  r0 = r0 + 1
Wend


    With sh1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("D" & r1min & ":D" & r0 - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E" & r1min & ":E" & r0 - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A" & r1min & ":F" & r0 - 1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


r1 = r1min
r2last = r2
While sh1.Cells(r1, 1) <> ""
 lt = sh1.Cells(r1, flds)
 wl = wl + lt
 While wl > maxwl
   If lt - wl + maxwl > 0 Then
     wo = lt - wl + maxwl
     sh1.Cells(r1, wek) = wo
     sh1.Cells(r1, wek).Interior.Color = sh1.Cells(r1, "D").Interior.Color
     If wek <> ant Then
      sh2.Cells(r2, 1) = "Week " & wek - flds - 1
      ant = wek
    End If
     If sh1.Cells(r1, 3) <> old Then
       sh2.Cells(r2last, 8) = "**"
       old = sh1.Cells(r1, 3)
     End If
     For j = 1 To 4
       sh2.Cells(r2, j + 1) = sh1.Cells(r1, j)
     Next j
     sh2.Cells(r2, 6) = sh1.Cells(r1, 6)
     sh2.Cells(r2, 7) = wo
     r2last = r2
     r2 = r2 + 1
   End If
   lt = wl - maxwl
   wek = wek + 1
   r2 = r2 + 1
   wl = lt
 Wend
 
  If lt > 0 Then
    sh1.Cells(r1, wek) = lt
    sh1.Cells(r1, wek).Interior.Color = sh1.Cells(r1, "D").Interior.Color
    If wek <> ant Then
      sh2.Cells(r2, 1) = "Week " & wek - flds - 1
      ant = wek
    End If
       
    If sh1.Cells(r1, 3) <> old Then
      sh2.Cells(r2last, 8) = "**"
      old = sh1.Cells(r1, 3)
    End If
    For j = 1 To 4
      sh2.Cells(r2, j + 1) = sh1.Cells(r1, j)
    Next j
    sh2.Cells(r2, 6) = sh1.Cells(r1, 6)
    sh2.Cells(r2, 7) = lt
    r2last = r2
    r2 = r2 + 1
  End If
 
  sh1.Cells(r1, "G") = "W " & wek - flds - 1
  sh1.Cells(r1, "G").Interior.Color = sh1.Cells(r1, "D").Interior.Color

 r1 = r1 + 1

Wend
sh2.Cells(r2last, 8) = "**"
For c = 1 To wek - flds - 1
  sh1.Cells(1, c + flds + 1) = "W " & WorksheetFunction.Text(c, "00")
Next c
 sh1.Select
 Range("A3").Select
 ActiveCell.CurrentRegion.EntireColumn.AutoFit
    
End Sub

Great, thanks. Do you do all this by writing code or recording macros?

How do I mark as solved?

Ocdawg

Originally Posted by Ocdawg

Great, thanks. Do you do all this by writing code or recording macros?

How do I mark as solved?

Ocdawg

I did this by writing code but from time to time I record an action to save time and learn.

Hi rcm,

I see this sorts alphabetically. What would I need to do if I wanted to sort by oldest average date of order?

Ocdawg