Как сопоставить информацию в двух динамических таблицах

Question

У меня есть два отчета.Одним из них являются номера предметов, которые были удалены из инвентаря.Другой - это проекты, которые получили предметы из инвентаря.Эти два отчета всегда имеют одинаковую общую сумму в долларах.Единственные столбцы с совпадающей информацией - это столбец A на листе, озаглавленный «Капитал-Данные», и столбец J на ​​листе, озаглавленный «Данные O & M».Обратите внимание, что реальные таблицы содержат тысячи строк и являются динамическими.Кроме того, рабочие листы НЕ имеют одинаковое количество строк.

На рабочем листе «Капитал-Данные» любые номера элементов, начинающиеся с «ITS», должны быть удалены из таблицы и перечислены НИЖЕ таблицы.

В таблице «O & M-Data» любой элемент в столбце J, соответствующий столбцу A из перечисленных элементов НИЖЕ таблицы в первом рабочем листе, также должен быть удален из таблицы «O & M-Data» и вставлен нижеТаблица.

Вот код, который я скопировал / написал:

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

Все это работает, кроме последнего раздела.Когда это происходит, он просто копирует первую строку рабочего листа «O & M-Data» под таблицей, удаляет пустые строки, а затем вставляет пустую строку под итогом.Кажется, что она полностью игнорирует команду для сопоставления ее с таблицей «Capital-Data».

У меня есть две небольшие таблицы примеров, которые я могу предоставить, если кто-нибудь подскажет, как прикрепить их к этому сообщению.Я думаю, что было бы намного проще, если бы вы могли видеть данные.

Любая помощь будет очень цениться!

Answer 1

РЕДАКТИРОВАТЬ - обновлено и протестировано в вашей учебной книге.

Проще собирать и перемещать любые строки, пока вы не закончите сравнение и фильтрацию.

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