Compare Amt between lines and move if matched

Hi all,

It's just a thought and I'm not sure if it's even possible.

Please see the sample I've attached.

I have a report that has thousands of lines... debits & credits. Most of them offset one another, 0 balance. However, there are still many w/ missing credits that need to be identied. Instead of going thru 10,000+ lines to pull out lines w/o credits - Is there a way that I can cross check the amount between lines (1&2, 2&3, 3&4 etc etc) and if their total is 0 then I want to move them to another sheet (Matched)?

Sorry if it's too confusing!

Thank you,

NTB

Hello NTB,

What about these lines? Do they not match?

02726747	10/23/2009	57			       -486.11
02726747	10/23/2009	00003801	Name2	C	486.11

Hello NTB,

What would you do when there are multiple credits applied to the same transaction?

Hello NTB,

That was fun. It works on the data you posted, but the real test is with the actual data. Run this on a copy of the original workbook to check the results. I added a button on the Data sheet to run the macro. Here is the macro code...

Sub CopyMatches()

  Dim Amount As Currency
  Dim Cell As Range
  Dim DataWks As Worksheet
  Dim Docs As Object
  Dim DocNum As Variant
  Dim MatchWks As Worksheet
  Dim NextRow As Long
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set DataWks = Worksheets("Data")
    Set MatchWks = Worksheets("Matched")
    
      Set Rng = DataWks.Range("A2")
      Set RngEnd = DataWks.Cells(Rows.Count, Rng.Column).End(xlUp)
      Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, DataWks.Range(Rng, RngEnd))
      
      NextRow = MatchWks.Cells(Rows.Count, "A").End(xlUp).Row
      NextRow = IIf(NextRow < 2, 2, NextRow + 1)
      
      Set Docs = CreateObject("Scripting.Dictionary")
      Docs.CompareMode = vbTextCompare
      
       'Sort the Data in ascending order by DocNum
        Rng.Resize(ColumnSize:=6).Sort Key1:=Rng.Cells(1, 1), Order1:=xlAscending, _
                                       Header:=xlYes, MatchCase:=False, _
                                       Orientation:=xlTopToBottom, _
                                       DataOption1:=xlSortTextAsNumbers
 
        For Each Cell In Rng
          DocNum = Cell.Text
          Amount = Cell.Offset(0, 5).Value
          DocType = Cell.Offset(0, 4).Text
          If Trim(DocNum) <> "" Then
            'Has DocNum be entered?
             If Not Docs.Exists(DocNum) Then
               'No - Check that the DocType is blank
                If DocType = "" Then
                   Docs.Add DocNum, Amount
                End If
             Else
               'Yes - Check that the DocType is "C" and the amounts equal zero
                If Cell.Offset(-1, 0) = DocNum And DocType = "C" Then
                   If Amount + Docs(DocNum) = 0 Then
                      'Copy the rows and clear the DocNum
                      Cell.Offset(-1, 0).Resize(2, 6).Copy MatchWks.Cells(NextRow, "A")
                      Cell.Offset(-1, 0).Resize(2, 1) = ""
                      NextRow = NextRow + 2
                   End If
                End If
             End If
          End If
        Next Cell
        
     'Delete the rows with no DocNum
      On Error Resume Next
      Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      
End Sub