3 Case Scenario VBA Code

[jalrs]

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

 

[jalrs]

Up.

Perhaps an if else else approach?

Thanks

 

[jalrs]

Got this a start but I have no idea how to address the comments
Perhaps with a starting code it's easier to see what I pretend.
Please assume I extract unique values from column C and paste them on column Q

Here is the current code, even tho it's not working.

Sub folhaplayyyy()

Dim livro1 As Workbook
Dim folha1 As Worksheet
Dim folha2 As Worksheet
Dim ultimalinha1 As Long, ultimalinha2 As Long, ultimalinha3 As Long, ultimalinha4 As Long, i As Long
Dim myrange As Range, valorunico As Range
Dim valorfiltro As String

Set livro1 = ThisWorkbook
Set folha1 = livro1.Worksheets("ZPO1")
Set folha2 = livro1.Worksheets("Play")

ultimalinha1 = folha1.Cells(Rows.Count, "A").End(xlUp).Row

folha2.UsedRange.Offset(1).Cells.ClearContents

    With folha1
    
        .Range("A2:P" & ultimalinha1).Copy
        folha2.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
        folha2.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
    
    End With
    
    ultimalinha2 = folha2.Cells(Rows.Count, "M").End(xlUp).Row
    ultimalinha3 = folha2.Cells(Rows.Count, "K").End(xlUp).Row
    ultimalinha4 = folha2.Cells(Rows.Count, "C").End(xlUp).Row
    
    Set myrange = folha2.Range("C2:C" & ultimalinha4)
    Set valorunico = folha2.Range("Q2")
    
    myrange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=myrange, CopyToRange:=valorunico, Unique:=True
    
    For Each valorunico In myrange
    
        If folha2.Range("M2:M" & ultimalinha2).WorksheetFunction.SumIf(Range("M2:M")) = 0 Then
            Delete.Rows
            
            ElseIf folha2.Range("M2:M" & ultimalinha2).WorksheetFunction.SumIf(Range("M2:M")) > 0 Then
            'don't do anything
            
                Else: folha2.Range("M2:M" & ultimalinha2).WorksheetFunction.SumIf (Range("M2:M")) > 0 And folha2.Range("L2:L" & ultimalinha2).WorksheetFunction.SumIf(Range("L2:L")) > 0
                
                    folha2.Rows.Insert Shift:=xlDown
                    
                    'new row, copy above row values, except for date, column E, column K, column L, and column M
                    'column K = aboveK-aboveL
                    'column M = columnK
                    'column L = 0
                    'column E = aboveE + 1
                    'date column, column J = Empty
                    
        End If
        
    Next valorunico
    
End Sub

Any help is greatly appreciated.

Thanks

 

[jalrs]

Up and still battling this out.

Any help is greatly appreciated.

Thanks

 

[Alex Blakenburg]

Its just not very clear what you are trying to do.
Firstly what are you trying to achieve in principle ?
Provide a before and after XL2BB of your data and include an example of each combination.

Your code is getting the Last Row at least 4 times on different columns. Why ? The expectation would be that the there is a last row for the data set with possibly a few exceptions, so you would only need to get the last row once.

 

[jalrs]

Good morning Alex,

So the first moment of the project, even tho out of scope, is to extract manually information from SAP and paste it there on the excel.

Now, within the scope of the project, the goal is to send suppliers an alert regarding materials that weren't sent yet, so they can update the estimated the new day.
The company only wants one email to be sent for each supplier (inside organization things, they segregate the merch by 4 teams, according if it's a mobile thing, fix thing, network materials, SIM cards, etc, but suppliers can be the same, that's why one email), so I extracted the unique values for each supplier code/name.
Therefore to achieve this, and to grant that what's extracted, when received back from the suppliers, it's integrated the same way on SAP, we need to check for one of those 3 conditions for each material on hold.

First we need to extract the unique values. Then, I need to filter the column where I have all supplier codes associated to all materials for each unique supplier code. Next, we need to check if the sum of quantity on hold equals 0. If yes, that means that there ano no materials on hold for that supplier so we can delete those rows. If not, if the sum of quantity on hold is > 0 leave it like that. And if not both of previous cases, and sum of quantity on hold is > 0 and the sum of scheduled material delivered for A date is > 0 we should add a new line and perform the commented actions, so the supplier can give a new estimated date for that quantity to be sent.

Then I can filter again for each supplier unique code and paste the information regarding each into each supplier template and then send to them, which I already did on my previous project.

Hope it is now a little bit more clear.

Regarding xl2bb, I can set it up, how much rows of data would you need? one for each scenario as the screenshot or two for each scenario?

Thanks Alex and sorry for the wall of text

 

[jalrs]

Its just not very clear what you are trying to do.
Firstly what are you trying to achieve in principle ?
Provide a before and after XL2BB of your data and include an example of each combination.

Your code is getting the Last Row at least 4 times on different columns. Why ? The expectation would be that the there is a last row for the data set with possibly a few exceptions, so you would only need to get the last row once.

Regarding the last row, I don't know, it doesn't make sense now that you ask me, probably just tired and thought that would do something different.

Thanks

 

[bebo021999]

With data is in sheet1, output is in sheet2

Option Explicit
Sub TEST()
Dim lr&, rng, i&, j&, k&, qp&, dr&, 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
    rng = .Range("A2:M" & lr).Value2
    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
        qp = 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)
                    If arr(k, 12) > 0 Then
                        qp = arr(k, 11) - arr(k, 12)
                        dr = arr(k, 5) + 1
                    End If
                Next
                If qp > 0 Then
                    k = k + 1
                    For j = 1 To 9
                        arr(k, j) = rng(i, j)
                    Next
                        arr(k, 5) = dr
                        arr(k, 10) = ""
                        arr(k, 11) = qp
                        arr(k, 12) = 0
                        arr(k, 13) = qp
                        qp = 0: dr = 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

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	Water	D	1	1	340	943		27-May	943	0	0
3	A	B	coke	D	1	1	340	5		21-Apr	5	0	0
4	A	B	coke	D	1	1	340	10000		03-May	10000	0	10000
5	A	B	tea	D	1	1	340	100		07-Jun	100	0	0
6	A	B	tea	D	1	1	340	600		05-Jul	600	300	600
Sheet1

Cell Formulas
Range	Formula
K2:K6	K2	=H2

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	coke	D	1	1	340	5		21/04/2022	5	0	0
3	A	B	coke	D	1	1	340	10000		03/05/2022	10000	0	10000
4	A	B	tea	D	1	1	340	100		07/06/2022	100	0	0
5	A	B	tea	D	1	1	340	600		05/07/2022	600	300	600
6	A	B	tea	D	2	1	340	600			300	0	300
Sheet2

 

[jalrs]

With data is in sheet1, output is in sheet2

Option Explicit
Sub TEST()
Dim lr&, rng, i&, j&, k&, qp&, dr&, 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
    rng = .Range("A2:M" & lr).Value2
    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
        qp = 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)
                    If arr(k, 12) > 0 Then
                        qp = arr(k, 11) - arr(k, 12)
                        dr = arr(k, 5) + 1
                    End If
                Next
                If qp > 0 Then
                    k = k + 1
                    For j = 1 To 9
                        arr(k, j) = rng(i, j)
                    Next
                        arr(k, 5) = dr
                        arr(k, 10) = ""
                        arr(k, 11) = qp
                        arr(k, 12) = 0
                        arr(k, 13) = qp
                        qp = 0: dr = 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

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	Water	D	1	1	340	943		27-May	943	0	0
3	A	B	coke	D	1	1	340	5		21-Apr	5	0	0
4	A	B	coke	D	1	1	340	10000		03-May	10000	0	10000
5	A	B	tea	D	1	1	340	100		07-Jun	100	0	0
6	A	B	tea	D	1	1	340	600		05-Jul	600	300	600
Sheet1

Cell Formulas
Range	Formula
K2:K6	K2	=H2

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	coke	D	1	1	340	5		21/04/2022	5	0	0
3	A	B	coke	D	1	1	340	10000		03/05/2022	10000	0	10000
4	A	B	tea	D	1	1	340	100		07/06/2022	100	0	0
5	A	B	tea	D	1	1	340	600		05/07/2022	600	300	600
6	A	B	tea	D	2	1	340	600			300	0	300
Sheet2

Hey bebo,

Thanks for this, I will need some time to understand it and put it to work.

I will do some tests and comeback to you.

Thank you very much

 

[jalrs]

With data is in sheet1, output is in sheet2

Option Explicit
Sub TEST()
Dim lr&, rng, i&, j&, k&, qp&, dr&, 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
    rng = .Range("A2:M" & lr).Value2
    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
        qp = 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)
                    If arr(k, 12) > 0 Then
                        qp = arr(k, 11) - arr(k, 12)
                        dr = arr(k, 5) + 1
                    End If
                Next
                If qp > 0 Then
                    k = k + 1
                    For j = 1 To 9
                        arr(k, j) = rng(i, j)
                    Next
                        arr(k, 5) = dr
                        arr(k, 10) = ""
                        arr(k, 11) = qp
                        arr(k, 12) = 0
                        arr(k, 13) = qp
                        qp = 0: dr = 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

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	Water	D	1	1	340	943		27-May	943	0	0
3	A	B	coke	D	1	1	340	5		21-Apr	5	0	0
4	A	B	coke	D	1	1	340	10000		03-May	10000	0	10000
5	A	B	tea	D	1	1	340	100		07-Jun	100	0	0
6	A	B	tea	D	1	1	340	600		05-Jul	600	300	600
Sheet1

Cell Formulas
Range	Formula
K2:K6	K2	=H2

Sample Sheet.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Doc	Item	Material	Description	DR	GM	GC	QPO	QF	DR	QP	QEM	QPEN
2	A	B	coke	D	1	1	340	5		21/04/2022	5	0	0
3	A	B	coke	D	1	1	340	10000		03/05/2022	10000	0	10000
4	A	B	tea	D	1	1	340	100		07/06/2022	100	0	0
5	A	B	tea	D	1	1	340	600		05/07/2022	600	300	600
6	A	B	tea	D	2	1	340	600			300	0	300
Sheet2

Hey Bebo, few notes on here since when you answered I had progressed already.

So would it be possible to do the checking regarding unique values on column P? Get unique values from Column P, paste them on column Q. And then for each unique value check the materials for each and for each material do the 3 checks? Unique values are the supplier code, so as you know, and as one supplier can have more than 1 material that.

Imagine, coca cola as my supplier, I refer to them with their supplier code, lets say 12345678. Inside coca cola they can deliver different types of materials (cokes) like diet coke, vanilla coke, cherry coke. I think you get the idea. another example, lipton, supplier code 87654321, they can deliver different types of materials (juices), like the peach flavour one, lemon flavour one, mango flavour one.

Other than that, I just noticed that your formula doesn't paste the dates as dates on my end nor the format numbers. Like the quantities must be preceded with ,000 so it doesn't break the SAP way of reading the file.

Don't think I spotted anything else.

Thank you so much, and hope it is possible to achieve what I asked as of now.