Macro to group rows with certain subtotal

I have a list of data in excel (many rows) and would like to group the rows based on subtotal of (pack qty) = 12.
Every row has different pack qty, so the macro can simply get the combination of qty, as long as the total = 12.

But the combination must be grouped by Color, Region#, Store Number.
You can check the data example in attached excel file.

Could anyone help to write the macro ? Because I have thousands of rows in 1 excel data that need to be processed.

Thanks a lot

ok..i have a question - what if there are rows where the sum of the pack qty is not equal to 12?

Hi.. sorry to add the information..
there's no problem if the sum of the rows not equal to 12..
the target would be, as long a the sum of the rows less or equal to 12.. but cannot exceed 12.

thankss..

How do you want to group the data? Should a blank row be inserted between the groups?

Yes, a blank row be inserted into the group of the rows. That would be great.

Thanks.

Hi, anyone can help on this ?

Please please.. thanks..

Will try something out today.

Try this code and let me know. Put it in a new module of your workbook and run it.

Sub group_data()

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ws1.Columns("A:I").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("G2") _
    , Order2:=xlAscending, Key3:=Range("I2"), Order3:=xlAscending, Header:= _
    xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal

lastrow = ws1.Range("A1").End(xlDown).Row

ws1.Rows("1:1").Copy
ws2.Select
Range("A1").Select
ActiveSheet.Paste
lrow = ws2.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    
    If ws1.Range("D" & i).Value = ws1.Range("D" & i + 1).Value Then
    
        If ws1.Range("E" & i).Value = ws1.Range("E" & i + 1).Value Then
        
            If ws1.Range("G" & i).Value = ws1.Range("G" & i).Value Then
                
proceed:
                qtysum = qtysum + ws1.Range("I" & i).Value
                
                If qtysum > 12 Then
                        
                    lrow = lrow + 1
                    qtysum = 0
                    i = i - 1
                            
                Else
                    
                    ws1.Rows(i & ":" & i).Cut
                    ws2.Activate
                    Range("A" & lrow + 1).Select
                    ActiveSheet.Paste
                    ws1.Rows(i & ":" & i).Delete
                    lastrow = lastrow - 1
                    lrow = lrow + 1
                    i = i - 1
                    
                End If
                               
            End If
        
        End If
    
    Else
            
        GoTo proceed
    
    End If

Next

End Sub

Let me know if you face any issues.

Hi.. seems your macro can run well, but my excel file keep hang there without responding.
So I cannot get the final result of it.

I've tried to close all excel and only open that excel and run the macro, but the result is still the same.

How is it at your end ? Do you manage to run it well in the excel that I attached for the sample file ?

Please help me.

Thanks.

Hi.. sorry, I manage to find how to stop it. I just press ESC in my keyboard and then choose to End the process.

I got the result already. Let me test with my real data.

Will update to you the soonest.

Thanks a lot.

You do not need to use the ESC to stop the code. I have just tweaked it a little bit and now it works fine. Just test it at your end and let me know if you face any issues.

Sub group_data()

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ws1.Columns("A:I").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("G2") _
    , Order2:=xlAscending, Key3:=Range("I2"), Order3:=xlDescending, Header:= _
    xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal

lastrow = ws1.Range("A1").End(xlDown).Row

ws1.Rows("1:1").Copy
ws2.Select
Range("A1").Select
ActiveSheet.Paste
lrow = ws2.Range("A" & Rows.Count).End(xlUp).Row

For i = lastrow To 2 Step -1
    
    If ws1.Range("D" & i).Value = ws1.Range("D" & i - 1).Value Then
    
        If ws1.Range("E" & i).Value = ws1.Range("E" & i - 1).Value Then
        
            If ws1.Range("G" & i).Value = ws1.Range("G" & i).Value Then
                
proceed:
                qtysum = qtysum + ws1.Range("I" & i).Value
                
                If qtysum > 12 Then
                        
                    lrow = lrow + 1
                    qtysum = 0
                   
                Else
                    
                    ws1.Rows(i & ":" & i).Cut
                    ws2.Activate
                    Range("A" & lrow + 1).Select
                    ActiveSheet.Paste
                    ws1.Rows(i & ":" & i).Delete
                    lastrow = lastrow - 1
                    lrow = lrow + 1
                                        
                End If
                               
            End If
        
        End If
    
    Else
            
        GoTo proceed
    
    End If

Next

End Sub

Hi, I tested ur new macro using some real data.

But i found there are lot of data not being calculated also.
I mean, for the pack qty > 12, then it's ok not being calculated. But how about those less than 12 ? why not move to Sheet2 also ?

I've attached another excel which I've tested using the macro.
Please take a look.

Thanks.

I ran the code several times but am not able to find the reason why they are not moving. Maybe someone else here can help us out.