How to match information in two dynamic tables

Question

I have two reports. One is Item Numbers which have been removed from Inventory. The other is Projects that have received items from Inventory. These two reports always have the same total dollar amount. The only columns with matching information is column A in the sheet entitled "Capital-Data" and column J in the sheet entitled "O&M-Data". Please note that the actual worksheets contain thousands of lines and are dynamic. Also, the worksheets do NOT have the same number of lines.

On the "Capital-Data" worksheet, any Item Numbers that begin with "ITS" must be removed from the table and listed BELOW the table.

On the "O&M-Data" table, any item in column J that matches column A of the items listed BELOW the table in the first worksheet must also be removed from the "O&M-Data" table and pasted below that table.

Here is the code I have copied/written:

Sub Candace()
'
' Candace Macro

Dim i As Long
Dim r As Long
Dim UsdRws As Long
Dim UsdRws2 As Long
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
Sheets("Capital-Data").Select
Dim lastrow As Long
lastrowsheet1 = Worksheets("Capital-Data").Cells(Rows.Count, 1).End(xlUp).Row
lastrowsheet2 = Worksheets("O&M-Data").Cells(Rows.Count, 1).End(xlUp).Row

    Selection.CurrentRegion.Select
    ActiveWorkbook.Worksheets("Capital-Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Capital-Data").Sort.SortFields.Add Key:=Range("E:E") _
        , sorton:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Capital-Data").Sort
        .SetRange Range("a1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = False

    UsdRws = Range("A1").CurrentRegion.Rows.Count

    For i = UsdRws To 2 Step -1
        If Range("E" & i).Value Like "ITS####" Then
        Rows(i).EntireRow.Cut
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveSheet.Paste
        End If
        Next i
        On Error Resume Next



    sourceCol = 1
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

    'for every row, find the first blank cell and select it
    For currentRow = rowCount To 2 Step -1
        currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Rows(currentRow).EntireRow.Delete
        End If
    Next


        Range("a1").End(xlDown).Offset(1).EntireRow.Insert
        Range("a1").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.CurrentRegion.Select


        Sheets("O&M-Data").Select
        Range("J2").Select

'Works great to this point

    For i = 2 To (lastrowsheet1 - 1)
     For j = 2 To (lastrowsheet2 - 1)
        If Worksheets("O&M-Data").Cells(i, 10) = Worksheets("Capital-Data").Cells(j, 1) Then
        Selection.EntireRow.Cut
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveSheet.Paste
        End If
     Next
    Next
    For currentRow = rowCount To 2 Step -1
        currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Rows(currentRow).EntireRow.Delete
        End If
    Next
      Application.ScreenUpdating = True
End Sub

It all works except for the last section. When it gets to that, it simply copies the first row of the "O&M-Data" worksheet below the table, deletes the blank rows, and then inserts a blank row below the total. It seems to be completely ignoring the command to match it to the "Capital-Data" table.

I have two small sample tables that I can provide if someone can tell me how to attach them to this post. I think it would be much easier if you could see the data.

Answer 1

EDIT - updated and tested on your sample workbook.

It's easier to batch up moving any rows until you're done comparing and filtering.

Sub Candace()

    Dim i As Long
    Dim r As Long
    Dim UsdRws As Long

    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
    Dim currentRowValue As String, lastrowCD As Long, lastrowOM As Long
    Dim lastrow As Long, wsCD As Worksheet, wsOM As Worksheet, j As Long
    Dim rngOp As Range, n As Long, rngOp2 As Range, rw As Range

    Set wsCD = ActiveWorkbook.Worksheets("Capital-Data")
    Set wsOM = ActiveWorkbook.Worksheets("O&M-Data")

    lastrowCD = wsCD.Cells(Rows.Count, 1).End(xlUp).Row
    lastrowOM = wsOM.Cells(Rows.Count, 1).End(xlUp).Row

    With wsCD.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsCD.Range("E:E"), SortOn:=xlSortOnValues, _
                        Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsCD.Range("A1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    UsdRws = wsCD.Range("A1").CurrentRegion.Rows.Count
    For i = UsdRws To 2 Step -1
        If wsCD.Range("E" & i).Value Like "ITS####" Then
            Build rngOp, wsCD.Rows(i) 'collecting a range to move....

            'find and collect matches on O&M sheet
            For j = 2 To (lastrowOM - 1)
               If wsOM.Cells(j, 10) = wsCD.Range("A" & i) Then
                   Build rngOp2, wsOM.Rows(j)
               End If
            Next
        End If
    Next i

    If Not rngOp Is Nothing Then
        rngOp.Copy wsCD.Range("A" & Rows.Count).End(xlUp).Offset(2)
        rngOp.Delete
    End If

    'move matched rows on OM sheet
    If Not rngOp2 Is Nothing Then
        rngOp2.Copy wsOM.Range("A" & Rows.Count).End(xlUp).Offset(2)
        rngOp2.Delete
    End If

End Sub

'utility Sub for building a range
Sub Build(ByRef rngTot As Range, ByRef rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub