3 Case Scenario VBA Code

jalrs

jalrs

Active Member
Joined
Apr 6, 2022
Messages
300
Office Version
  1. 365
Platform
  1. Windows
Hello guys,

I don't know how to approach this nor if it is the right request to make. I believe with the attached screenshots will make it easier to understand.
So what I would like to is:

1st : Check each material on column C
2nd: 1st case - If the sum of column M is equal to 0 for each material, then delete those lines (water on the example)
2nd case - If the sum of column M is # 0 for each material, then leave it like that (coke on the example)
3rd case - If the sum of column M is # 0 and column L is greater than 0, add a new line under the one where column L is greater than 0 where column K = K-L from previous row, colum L is now 0, and column M equals to column K value. Plus Column E new line is +1 regarding the previous line value. Rest of the values should be equal to the ones on the previous line, except for the date that should be left empty. (tea example. date not correct on the output.png sorry)

Hope this is possible and hope someone can help me.

Please look at the input vs output attachment.

Any help is greatly appreciated.

Thanks
 

Attachments

  • input.png
    input.png
    18.9 KB · Views: 21
  • output.png
    output.png
    21.9 KB · Views: 22
Sort by date Sort by votes
It may helps a lot if you could post a mini-sheet via XL2BB, like what I did in post #8
www.mrexcel.com

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...
www.mrexcel.com www.mrexcel.com
Try to post your actual details (codes, ...) but not sensitive data, as much as possible.
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
bebo021999 said:
It may helps a lot if you could post a mini-sheet via XL2BB, like what I did in post #8
www.mrexcel.com

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...
www.mrexcel.com www.mrexcel.com
Try to post your actual details (codes, ...) but not sensitive data, as much as possible.
Click to expand...
Sure bebo, I can only do it from my personal computer due to company network privacy settings.

Since I won't get to home until tomorrow, I can't make it at the moment, but I I will do it tomorrow when I arrive home at lunch time (should be around 18h in your time zone).

Thanks for your time!
 
Upvote 0
Hey @bebo021999

bebo.xlsm
ABCDEFGHIJKLM
1OrderItemMatNameDescriptionRemGMGCQPOQFDATEQPROQEMQPEN
2111111111100001Acoke zero0001A11943,0000,00027/05/2022943,0000,0000,000
3111111111100001Bcoke0001A11943,0000,00027/05/2022943,0000,000943,000
4222222222200001Aice tea lemon0002A11633,000400,00028/12/2022500,0000,0000,000
5222222222200001Bice tea peach0002A11633,000400,00028/12/2022500,0000,000100,000
6222222222200001Cice tea mango0002A11633,000400,00028/12/2022500,000400,000100,000
7333333333300001Adr pepper0001A111 200,000758,00029/04/20221 200,000758,000442,000
8444444444400001Apepsi max0001A11200,0000,00029/04/2022200,0000,000200,000
Input


bebo.xlsm
ABCDEFGHIJKLM
1OrderItemMatNameDescriptionRemGMGCQPOQFDATEQPROQEMQPEN
2111111111100001Bcoke0001A11943,0000,00027/05/2022943,0000,000943,000
3222222222200001Bice tea peach0002A11633,000400,00028/12/2022500,0000,000100,000
4222222222200001Cice tea mango0002A11633,000400,00028/12/2022400,000400,0000,000
5222222222200001Cice tea mango0003A11633,000100,000100,0000,000100,000
6333333333300001Adr pepper0001A111 200,000758,00029/04/2022758,000758,0000,000
7333333333300001Adr pepper0002A111 200,000442,000442,0000,000442,000
8444444444400001Apepsi max0001A11200,0000,00029/04/2022200,0000,000200,000
Output


Few notes since I adjusted this to look more real and with proper names. de sensitive tho.
1st. Filter by Order
2nd. Filter by MatName
3rd. For each MatName inside each order. If QPEN sum = 0. remove row ; If QPEN sum > 0 And QEM sum = 0 do nothing; if QPEN Sum > 0 and QEM Sum > 0 add new row.
4th. New row QPRO = QPEN original row; QPEN New row = QPRO new row ; QF New row = QEM original row ; Rem new row = Rem original row +1; Date New row = Empty ; Rest of columns new row = Rest of columns original row
5th. Original row QPRO = original row QPRO - original row QPEN ; Original row QPEN = 0
6th. Next MatName
7thNext order

It doesn't change much as much I can evaluate from the code. Note that cell formats and value formats should be kept otherwise SAP won't recognize according to the boss.

Thanks bebo
 
Upvote 0
Sorry for late reply!
Try again. Hope it works.
VBA Code: 
Option Explicit
Sub TEST()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
    rng = .Range("A2:M" & lr).Value
    For i = 1 To lr - 1
        id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
        If Not dic.exists(id) Then
            dic.Add id, rng(i, 12) & "-" & rng(i, 13)
        Else
            dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
        End If
    Next
    For Each key In dic.keys
        qpen = 0
        For i = 1 To lr - 1
            id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
            If Split(dic(key), "-")(1) > 0 And key = id Then
                k = k + 1
                For j = 1 To 13
                    arr(k, j) = rng(i, j)
                Next
                    If arr(k, 12) > 0 Then
                        qpen = arr(k, 11) - arr(k, 12)
                        re = arr(k, 5) + 1
                        arr(k, 11) = arr(k, 12)
                        arr(k, 13) = 0
                    End If
                If qpen > 0 Then
                    k = k + 1
                    For j = 1 To 10
                        arr(k, j) = rng(i, j)
                    Next
                        arr(k, 5) = re
                        arr(k, 11) = qpen
                        arr(k, 12) = 0
                        arr(k, 13) = qpen
                        qpen = 0: re = 0
                End If
            End If
        Next
    Next
End With
With Worksheets("Sheet2")
.Range("A2:M100000").ClearContents
.Range("A2").Resize(k, 13).Value = arr
End With
End Sub
 
Upvote 0
bebo021999 said:
Sorry for late reply!
Try again. Hope it works.
VBA Code: 
Option Explicit
Sub TEST()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
    rng = .Range("A2:M" & lr).Value
    For i = 1 To lr - 1
        id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
        If Not dic.exists(id) Then
            dic.Add id, rng(i, 12) & "-" & rng(i, 13)
        Else
            dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
        End If
    Next
    For Each key In dic.keys
        qpen = 0
        For i = 1 To lr - 1
            id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
            If Split(dic(key), "-")(1) > 0 And key = id Then
                k = k + 1
                For j = 1 To 13
                    arr(k, j) = rng(i, j)
                Next
                    If arr(k, 12) > 0 Then
                        qpen = arr(k, 11) - arr(k, 12)
                        re = arr(k, 5) + 1
                        arr(k, 11) = arr(k, 12)
                        arr(k, 13) = 0
                    End If
                If qpen > 0 Then
                    k = k + 1
                    For j = 1 To 10
                        arr(k, j) = rng(i, j)
                    Next
                        arr(k, 5) = re
                        arr(k, 11) = qpen
                        arr(k, 12) = 0
                        arr(k, 13) = qpen
                        qpen = 0: re = 0
                End If
            End If
        Next
    Next
End With
With Worksheets("Sheet2")
.Range("A2:M100000").ClearContents
.Range("A2").Resize(k, 13).Value = arr
End With
End Sub
Click to expand...
Hey bebo,

No need to say sorry, weekends aren't meant to work :) everyone deserves their rest time.

Few notes at first glance:

The date on the new row should be left blank, that's where the supplier will fill the new estimated date for delivery (for context)
Number values aren't being past accordingly, I mean, at input sheet we have numbers displayed like: "1,000" on the output I get "1"
On "A:G" range you can see cells have format (yellow colour), and on the output I'm not getting that.

I believe it should be a quick fix.

Nonetheless thank you very much for the already working code even tho if not to the fullest.

I idented the code, might be easy for you to look at:

VBA Code: 
Sub TEST1()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key

Set dic = CreateObject("scripting.dictionary")

    With Worksheets("ZPO1")
    
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        
        .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
        
        rng = .Range("A2:M" & lr).Value
        
            For i = 1 To lr - 1
            
                id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
                
                    If Not dic.exists(id) Then
                    
                        dic.Add id, rng(i, 12) & "-" & rng(i, 13)
                        
                    Else
                    
                        dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
            
                    End If
                    
            Next
            
            For Each key In dic.keys
        
                qpen = 0
        
                For i = 1 To lr - 1
        
                    id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
            
                        If Split(dic(key), "-")(1) > 0 And key = id Then
            
                            k = k + 1
                            
                                For j = 1 To 13
                                
                                    arr(k, j) = rng(i, j)
                                    
                                Next
                                
                                    If arr(k, 12) > 0 Then
                                    
                                        qpen = arr(k, 11) - arr(k, 12)
                                        re = arr(k, 5) + 1
                                        arr(k, 11) = arr(k, 12)
                                        arr(k, 13) = 0
                        End If
                        
                        If qpen > 0 Then
                        
                            k = k + 1
                            
                                For j = 1 To 10
                                
                                    arr(k, j) = rng(i, j)
                        
                                Next
                                
                            arr(k, 5) = re
                            arr(k, 11) = qpen
                            arr(k, 12) = 0
                            arr(k, 13) = qpen
                            qpen = 0: re = 0
                            
                        End If
                        
                End If
                
            Next
            
        Next
        
    End With
    
    With Worksheets("Play")

        .Range("A2:M100000").ClearContents
        .Range("A2").Resize(k, 13).Value = arr

    End With
    
End Sub

Thanks!
 
Upvote 0
Try again.
To help you control the code, I add comments within the code body:

VBA Code: 
Sub TEST1()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key

Set dic = CreateObject("scripting.dictionary")

    With Worksheets("ZPO1")
    
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        
        .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
        'store sheet value into an array variable to increase speed
        rng = .Range("A2:M" & lr).Value
        
            For i = 1 To lr - 1
            
                id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
                'store unique column A,B,C,D text into a dictionary, with key like: "222222-1-C-ice tea mango"
                'and item like "400-100". From this item, to identify if line need to be dupplicated or not
                
                    If Not dic.exists(id) Then
                    'key generator
                        dic.Add id, rng(i, 12) & "-" & rng(i, 13)
                        
                    Else
                    'item generator
                        dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
            
                    End If
                    
            Next
            
            For Each key In dic.keys
        
                qpen = 0
        
                For i = 1 To lr - 1
        
                    id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
            
                        If Split(dic(key), "-")(1) > 0 And key = id Then 'work with rows with qpen>0
            
                            k = k + 1
                            
                                For j = 1 To 13
                                
                                    arr(k, j) = rng(i, j)
                                    
                                Next
                                
                                    If arr(k, 12) > 0 Then
                                    
                                        qpen = arr(k, 11) - arr(k, 12)
                                        re = arr(k, 5) + 1
                                        arr(k, 11) = arr(k, 12)
                                        arr(k, 13) = 0
                        End If
                        'works with special rows with qem > 0
                        If qpen > 0 Then
                        'add new line
                            k = k + 1
                                
                                For j = 1 To 9
                                'kepp original data
                                    arr(k, j) = rng(i, j)
                        
                                Next
                                
                            arr(k, 5) = re
                            arr(k, 10) = ""
                            arr(k, 11) = qpen
                            arr(k, 12) = 0
                            arr(k, 13) = qpen
                            qpen = 0: re = 0
                            
                        End If
                        
                End If
                
            Next
            
        Next
        
    End With
    
    With Worksheets("Play")
        .Range("A2:M100000").ClearContents
        .Range("A2").Resize(k, 13).Value = arr
        .Range("E2").Resize(k, 1).NumberFormat = "00000" ' Format column E
    End With
    
End Sub
 
Upvote 0
bebo021999 said:
Try again.
To help you control the code, I add comments within the code body:

VBA Code: 
Sub TEST1()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key

Set dic = CreateObject("scripting.dictionary")

    With Worksheets("ZPO1")
   
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
       
        .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
        'store sheet value into an array variable to increase speed
        rng = .Range("A2:M" & lr).Value
       
            For i = 1 To lr - 1
           
                id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
                'store unique column A,B,C,D text into a dictionary, with key like: "222222-1-C-ice tea mango"
                'and item like "400-100". From this item, to identify if line need to be dupplicated or not
               
                    If Not dic.exists(id) Then
                    'key generator
                        dic.Add id, rng(i, 12) & "-" & rng(i, 13)
                       
                    Else
                    'item generator
                        dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
           
                    End If
                   
            Next
           
            For Each key In dic.keys
       
                qpen = 0
       
                For i = 1 To lr - 1
       
                    id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
           
                        If Split(dic(key), "-")(1) > 0 And key = id Then 'work with rows with qpen>0
           
                            k = k + 1
                           
                                For j = 1 To 13
                               
                                    arr(k, j) = rng(i, j)
                                   
                                Next
                               
                                    If arr(k, 12) > 0 Then
                                   
                                        qpen = arr(k, 11) - arr(k, 12)
                                        re = arr(k, 5) + 1
                                        arr(k, 11) = arr(k, 12)
                                        arr(k, 13) = 0
                        End If
                        'works with special rows with qem > 0
                        If qpen > 0 Then
                        'add new line
                            k = k + 1
                               
                                For j = 1 To 9
                                'kepp original data
                                    arr(k, j) = rng(i, j)
                       
                                Next
                               
                            arr(k, 5) = re
                            arr(k, 10) = ""
                            arr(k, 11) = qpen
                            arr(k, 12) = 0
                            arr(k, 13) = qpen
                            qpen = 0: re = 0
                           
                        End If
                       
                End If
               
            Next
           
        Next
       
    End With
   
    With Worksheets("Play")
        .Range("A2:M100000").ClearContents
        .Range("A2").Resize(k, 13).Value = arr
        .Range("E2").Resize(k, 1).NumberFormat = "00000" ' Format column E
    End With
   
End Sub
Click to expand...

Hey bebo, thanks for the comments on the code, makes it easier indeed to read it.

I had suspicious of this being an array, which definitely speeds up the code like bonkers. It's crazy the difference between this and my other project code in terms of speed. This works in a blink of an eye.

I will try as soon as possible and get back to you to provide feedback.

Thanks bebo, once again!
 
Upvote 0
bebo021999 said:
Try again.
To help you control the code, I add comments within the code body:

VBA Code: 
Sub TEST1()
Dim lr&, rng, i&, j&, k&, qpen&, re&, id As String, arr(1 To 100000, 1 To 13)
Dim dic As Object, key

Set dic = CreateObject("scripting.dictionary")

    With Worksheets("ZPO1")
  
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
      
        .Range("A2:M" & lr).Sort key1:=.Range("A1"), key2:=.Range("B1"), key3:=.Range("C1")
        'store sheet value into an array variable to increase speed
        rng = .Range("A2:M" & lr).Value
      
            For i = 1 To lr - 1
          
                id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
                'store unique column A,B,C,D text into a dictionary, with key like: "222222-1-C-ice tea mango"
                'and item like "400-100". From this item, to identify if line need to be dupplicated or not
              
                    If Not dic.exists(id) Then
                    'key generator
                        dic.Add id, rng(i, 12) & "-" & rng(i, 13)
                      
                    Else
                    'item generator
                        dic(id) = Split(dic(id), "-")(0) + rng(i, 12) & "-" & Split(dic(id), "-")(1) + rng(i, 13)
          
                    End If
                  
            Next
          
            For Each key In dic.keys
      
                qpen = 0
      
                For i = 1 To lr - 1
      
                    id = rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-" & rng(i, 4)
          
                        If Split(dic(key), "-")(1) > 0 And key = id Then 'work with rows with qpen>0
          
                            k = k + 1
                          
                                For j = 1 To 13
                              
                                    arr(k, j) = rng(i, j)
                                  
                                Next
                              
                                    If arr(k, 12) > 0 Then
                                  
                                        qpen = arr(k, 11) - arr(k, 12)
                                        re = arr(k, 5) + 1
                                        arr(k, 11) = arr(k, 12)
                                        arr(k, 13) = 0
                        End If
                        'works with special rows with qem > 0
                        If qpen > 0 Then
                        'add new line
                            k = k + 1
                              
                                For j = 1 To 9
                                'kepp original data
                                    arr(k, j) = rng(i, j)
                      
                                Next
                              
                            arr(k, 5) = re
                            arr(k, 10) = ""
                            arr(k, 11) = qpen
                            arr(k, 12) = 0
                            arr(k, 13) = qpen
                            qpen = 0: re = 0
                          
                        End If
                      
                End If
              
            Next
          
        Next
      
    End With
  
    With Worksheets("Play")
        .Range("A2:M100000").ClearContents
        .Range("A2").Resize(k, 13).Value = arr
        .Range("E2").Resize(k, 1).NumberFormat = "00000" ' Format column E
    End With
  
End Sub
Click to expand...
Hey bebo,

Regarding the date, it is now correct.

What is missing:

On column B, i'm not getting the correct value pasted. 00010 is being pasted as 10, 00100 is being pasted as 100, 00030 is being pasted as 30.
On columns H, I, K, L, M numbers aren't being displayed as they should yet. 1,000 should be displayed as 1,000 and it is being displayed as 1 (for example)
Still missing the format, yellow filled cells, from cells A2:G

Hope it is fixable.

Thanks!
 
Upvote 0
With Xl2BB, format may change and different from it appears.
Just play around with format function as my last row of code.
Try it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

togenmoser
  • Solved
Help with VBA code error "For variable already in use"
2 3
Replies
22
Views
565
MARK858
MARK858
MrDB4Excel
  • Solved
Disregard Negative Results
Replies
3
Views
133
Joe4
Joe4
K
  • Question
Using VBA to select a color coded cell
Replies
1
Views
159
bobaol
B
E
  • Question
Function to return array of 10 largest absolute values while maintaining sign
Replies
0
Views
129
eurobonds
E
T
  • Question
VBA code to multiply many rows with some conditions
Replies
6
Views
205
DanteAmor
DanteAmor

Forum statistics

Threads
1,216,194
Messages
6,129,449
Members
449,509
Latest member
ajbooisen

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top