Macro to remove similar lines in another sheet

[Mile029]

Hi I'm looking to create a macro that will look at one columns and if number in the rows match, look at an amount column and see if the values total to zero, if so, then remove the rows from the sheet and paste in another sheet. I've attached a sample of the data. Basically the macro would look at column E (External Document No.) if the value in the rows is the same, then look at column K (Amount) for those rows. If the amounts for those rows total to zero, then cut and paste those rows into another sheet, leaving items that have yet to match. This is for a reconciliation I'm trying to put together. Please help as it is tedious to go through all of these rows and rows of data. Thanks.

Example:
IS1002711 is in rows 2-4, amounts in each row if added together would be zero, since that is the case all three rows will be cut and pasted into another sheet, removing them from this sheet.

[Kaper]

Try a macro in attached workbook. It shall do the job.
It is assumed that the data is sorted on column E. if not,

Please Login or Register  to view this content.

shall be added before

Please Login or Register  to view this content.

At the moment it leaves an empty line between each moved set of rows (for single EDN) if you do not like these lines change

Please Login or Register  to view this content.

to

Please Login or Register  to view this content.

The whole code:

Please Login or Register  to view this content.

PS. Please update your profile. Seems you now don't use Excel 2003

[Marc L]

According to the attachment as a VBA beginner starter to paste to the Sheet1 worksheet module :

Sub Demo1() 
         Const F = "IF({1},ROUND(SUMIF(E2:E#,E2:E#,K2:K#),2)=0)" 
         Application.ScreenUpdating = False 
    With Me.UsedRange.Columns("A:P") 
           .Range("P2:P" & .Rows.Count) = Evaluate(Replace(F, "#", .Rows.Count)) 
        If IsNumeric(Application.Match(True, .Item(16), 0)) Then 
            If Worksheets.Count = 1 Then Sheets.Add , Me Else Sheets(2).UsedRange.Clear 
           .Range("A1:O1").Copy Sheets(2).[A1] 
           .Sort .Item(16), xlAscending, Header:=xlYes 
           .Range("A" & Application.Match(True, .Item(16), 0) & ":O" & .Rows.Count).Cut Sheets(2).[A2] 
            Sheets(2).UsedRange.Columns.AutoFit 
        End If 
           .Item(16).Clear 
    End With 
         Application.ScreenUpdating = True 
End Sub  

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[Mile029]

Awesome Kaper, this does work perfectly. The data will not always be sorted so I removed the ' you had as a comment in the macro so the line is now added. I do like the space as it shows like items together so I may keep it. Thank you so much, this works perfectly! It is going to save me so much time when reconciling! Thanks again.

[Marc L]

Mike,

according to your initial attachment just compare the result between post #2 & 3, what is remaining in Sheet1 …

[Mile029]

Hi Kaper, only issue I'm having is that it can be run only once over the data. Is there a way to append to the data in Sheet2? I see the paste function adds to Cells (1, 1), is there a way to add to the next blank cell in column instead of Cell A1? If I add new data to Sheet1, I would like to rerun the macro. Thanks!

[Mile029]

Marc L, this works awesome also. I like that it wipes out the data that is in sheet2 and puts the new reconciled items there. Is there a way to make it append to the items in sheet2 instead?

[Marc L]

Did you see at least the difference between posts #2 & 3 codes with your initial attachment ?

[Mile029]

Did you see at least the difference between posts #2 & 3 codes with your initial attachment ?

Yes, they are both doing the same thing and leaving the same results, only difference I see is that the second code doesn't arrange the results on sheet two grouped. I feel the first code is cleaner in the sense it groups the results so I know exactly what cleared. Otherwise, the results in sheet1 is really what I'm looking for, so both provide the same results. If Sheet2 can append results it would be better. Thanks for your help.

[Kaper]

As for main question addressed to me, see code after some cleaning (done on smartphone so not tested, but as it was just removing some lines, shall work easily):

Please Login or Register  to view this content.

[Marc L]

Yes, they are both doing the same thing and leaving the same results,

Very not according to your initial attachment : with post #2 code many rows to be moved to Sheet2 remain in Sheet1 …

[Mile029]

As for main question addressed to me, see code after some cleaning (done on smartphone so not tested, but as it was just removing some lines, shall work easily):

Please Login or Register  to view this content.

Sorry this code didn't work, I will use the original code. Thanks.

[Mile029]

Very not according to your initial attachment : with post #2 code many rows to be moved to Sheet2 remain in Sheet1 …

I ran the first macro on more data Marc L, seems like you are right, with more data it does not work, it groups the items together and even moves non zero items to the Sheet2, your's does not. Thanks for pointing that out. I'll use yours! I did like the grouping of items though.

[Marc L]

Thanks for the rep' !

According to grouping items with Kaper's code, you just need to sort the column E before …

[Marc L]

Keeping the same kid logic helper column my demonstration revamped for 'grouping items' :

Sub Demo1r() 
    With Me.UsedRange.Rows 
              C = Application.Match("External Document No.", .Item(1), 0) 
              H = Application.Match("Amount", .Item(1), 0) 
              If IsError(C) Or IsError(H) Then Beep: Exit Sub 
        With .Item("2:" & .Count).Columns 
              V = Evaluate(Replace("IF({1},ROUND(SUMIF(#,#,", "#", .Item(C).Address) & .Item(H).Address & "),2)=0)") 
              If IsError(Application.Match(True, V, 0)) Then Beep: Exit Sub 
              H = .Count + 1 
              Application.ScreenUpdating = False 
             .Item(H) = V 
        End With 
        If Worksheets.Count = 1 Then 
            Sheets.Add , Me 
            With ActiveWindow:  .SplitColumn = 0:  .SplitRow = 1:  .FreezePanes = True:  End With 
        Else 
            Sheets(2).UsedRange.Clear 
        End If 
             .Item(1).Copy Sheets(2).[A1] 
             .Resize(, H).Sort .Columns(H), xlAscending, Header:=xlYes 
        With .Item(Application.Match(True, .Columns(H), 0) & ":" & .Count) 
             .Sort .Cells(C), xlDescending, Header:=xlNo 
              V = .Count 
         Do 
              F = Application.Match(.Cells(V, C), .Columns(C), 0) 
             .Item(F & ":" & V).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(3) 
              V = F - 1 
         Loop While V 
             .Clear 
        End With 
             .Columns(H).Clear 
    End With 
              Sheets(2).UsedRange.Columns.AutoFit 
              Application.ScreenUpdating = True 
End Sub  

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[Marc L]

If a blank row between 'groups' is not necessary the faster way is
to just add an unique codeline in my first demonstration to sort the result sheet …

[Mile029]

Keeping the same kid logic helper column my demonstration revamped for 'grouping items' :

Sub Demo1r() 
    With Me.UsedRange.Rows 
              C = Application.Match("External Document No.", .Item(1), 0) 
              H = Application.Match("Amount", .Item(1), 0) 
              If IsError(C) Or IsError(H) Then Beep: Exit Sub 
        With .Item("2:" & .Count).Columns 
              V = Evaluate(Replace("IF({1},ROUND(SUMIF(#,#,", "#", .Item(C).Address) & .Item(H).Address & "),2)=0)") 
              If IsError(Application.Match(True, V, 0)) Then Beep: Exit Sub 
              H = .Count + 1 
              Application.ScreenUpdating = False 
             .Item(H) = V 
        End With 
        If Worksheets.Count = 1 Then 
            Sheets.Add , Me 
            With ActiveWindow:  .SplitColumn = 0:  .SplitRow = 1:  .FreezePanes = True:  End With 
        Else 
            Sheets(2).UsedRange.Clear 
        End If 
             .Item(1).Copy Sheets(2).[A1] 
             .Resize(, H).Sort .Columns(H), xlAscending, Header:=xlYes 
        With .Item(Application.Match(True, .Columns(H), 0) & ":" & .Count) 
             .Sort .Cells(C), xlDescending, Header:=xlNo 
              V = .Count 
         Do 
              F = Application.Match(.Cells(V, C), .Columns(C), 0) 
             .Item(F & ":" & V).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(3) 
              V = F - 1 
         Loop While V 
             .Clear 
        End With 
             .Columns(H).Clear 
    End With 
              Sheets(2).UsedRange.Columns.AutoFit 
              Application.ScreenUpdating = True 
End Sub  

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

Thanks for the rep' !

According to grouping items with Kaper's code, you just need to sort the column E before …

Okay, I'll add that to the macro, sort Column "External Document No." prior to macro start and then sort by Column "Posting Date" when macro is finished. Not a bad idea. Thanks for the help. After I was working with a larger set of data though, I realized that External Document No. column had some numbers after the first nine characters. It seems that they were part of the original number, for example it would have the following:
IS1008278
IS1008278 3
IS1008278 4

When the 3 and 4 Document No lines come into play, it does zero out. Anyway to make it sum by the first nine characters rather than an exact match?

[Mile029]

Also the new code above is giving me a "Type Mismatch" error. I've attached the workbook with the new code. Thanks for your help MarkL!

[Marc L]

Maybe something weird with the data, I will check it out later …

But before to waste maybe my time I need a clear answer to the post #16 question :
a blank line between 'groups' is it really necessary ? As that's slower than to cut all the block at once …

[Marc L]

(removed, see below)

[Marc L]

According to your post #18 attachment a faster way playing with an array
to paste in a regular module (easier for debugging if necessary) and
if you need a blank row between each group just set the constant D to 3 :

Sub Demo2() 
      Const D = 2 
        Dim C(1), V, F&, T@, R& 
    With Sheet1.[A1].CurrentRegion.Rows 
            C(0) = Application.Match("Inbound Shipment No", .Item(1), 0) 
            C(1) = Application.Match("Amount", .Item(1), 0) 
            If Application.Count(C) <= UBound(C) Then Beep: Exit Sub 
            Application.ScreenUpdating = False 
           .Item(1).Copy Sheet2.[A1] 
           .Sort .Cells(C(0)), xlAscending, Header:=xlYes 
            V = Application.Index(.Value2, Evaluate("ROW(1:" & .Count & ")"), C) 
            F = 2:  T = V(2, 2) 
        For R = 3 To .Count 
            If V(R, 1) = V(F, 1) Then 
                T = T + V(R, 2) 
            Else 
                If T = 0 Then .Item(F & ":" & R - 1).Cut Sheet2.Cells(Rows.Count, 1).End(xlUp)(D) 
                F = R:  T = V(R, 2) 
            End If 
        Next 
            If T = 0 Then .Item(F & ":" & R - 1).Cut Sheet2.Cells(Rows.Count, 1).End(xlUp)(D) 
           .Sort .Cells(2), xlAscending, Header:=xlYes 
           .Item(.Cells(1).End(xlDown)(2).Row & ":" & .Count).EntireRow.Delete 
    End With 
            Sheet2.UsedRange.Columns.AutoFit 
            Application.ScreenUpdating = True 
End Sub  

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[Marc L]

If a blank row between each group is not necessary a faster way than my previous demonstration #2
- ~ 2 seconds less on my side with post #18 attachment -
is still the kid way logic like in my first demonstration but this time just tweaking it to avoid duplicate SUMIF calculations …

[Marc L]

According to post #18 attachment without any blank row in Sheet2 the fastest way - all job done in 1.3s on an old slow laptop ! - is to revamp
my demonstration #2 playing with one more array for the helper column in order to copy and delete rows at once …