匹配特定列中的值的行并将匹配/不匹配的行粘贴到新工作表中

Question

我在 sheet1 和 sheet2 中获得了数据，我想将它们复制并粘贴到 sheet3 中。那已经完成了。所以接下来我想通过检查列 C、D、E、H 和 I 来匹配行。C 和 H 列的值是整数，其余的是文本/字符串。

如果两行匹配，那么我想将其中一行复制并粘贴到新的第三张纸中，并在 H 列中添加与 H 列的整数差（如果所有列中的行都匹配，则差值为 0）

如果两行不匹配，将其中一行复制并粘贴到新的第四张纸中，并在 H 列中添加与 H 列的整数差

到目前为止的代码：

Sub CopyPasteSheet()

    Dim mySheet, arr

    arr = Array("Sheet1", "Sheet2")
    Const targetSheet = "Sheet3"

    Application.ScreenUpdating = False

    For Each mySheet In arr
        Sheets(mySheet).Range("A1").CurrentRegion.Copy
            With Sheets(targetSheet)
                .Range("A1").Insert Shift:=xlDown
                If mySheet <> arr(UBound(arr)) Then .Rows(1).Delete xlUp
            End With
    Next mySheet

    Application.ScreenUpdating = True

End Sub

Answer 1

除非性能太慢，否则通过一次一行写入输出表来消除数组的复杂性。

更新 - 复制完整行

Option Explicit

Sub MatchRows2()

    Dim dic As Object, key As String
    Set dic = CreateObject("Scripting.Dictionary")

    Dim wb As Workbook
    Dim ws As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim iLastRow As Long, s As String, diff As Long
    Dim iRow3 As Long, iRow4 As Long, i As Long, t0 As Single
    Dim rng As Range
    t0 = Timer
    s = "|"

    Set wb = ThisWorkbook
    ' sheet 2
    Set ws = wb.Sheets("Sheet2")
    iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
    For i = 2 To iLastRow
       key = ws.Cells(i, "C") & s & ws.Cells(i, "D") _
             & s & ws.Cells(i, "E") & s & ws.Cells(i, "I")
       If dic.exists(key) Then
           MsgBox "Duplicate key '" & key & "'", vbCritical, "Sheet2 Row " & i
           Exit Sub
       Else
          dic.Add key, ws.Cells(i, "H")
       End If
    Next
    Debug.Print dic.Count

    ' results
    Set ws3 = wb.Sheets("Sheet3")
    iRow3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row

    Set ws4 = wb.Sheets("Sheet4")
    iRow4 = ws4.Cells(Rows.Count, "A").End(xlUp).Row
   
    'sheet 1
    Application.ScreenUpdating = False
    Set ws = wb.Sheets("Sheet1")
    iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
    For i = 2 To iLastRow
       key = ws.Cells(i, "C") & s & ws.Cells(i, "D") _
             & s & ws.Cells(i, "E") & s & ws.Cells(i, "I")
       If dic.exists(key) Then
           diff = ws.Cells(i, "H") - dic(key)
           If diff = 0 Then
               iRow3 = iRow3 + 1
               Set rng = ws3.Cells(iRow3, "A")
           Else
               iRow4 = iRow4 + 1
               Set rng = ws4.Cells(iRow4, "A")
           End If
           ws.Rows(i).Copy rng
           rng.Offset(0, 7).Value = diff ' col H
       End If
    Next
    Application.ScreenUpdating = True

    MsgBox "Done in " & Format(Timer - t0, "0.0 secs"), vbInformation

End Sub

Answer 2

到目前为止的代码，但我收到代码错误“应用程序定义或对象定义错误”。它确实将匹配的行复制到一个新的工作表中，并在 H 列中将差异声明为 0，但它不适用于不匹配的行。

Sub MatchRows()
    Dim a As Variant, b As Variant, c As Variant, d As Variant
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim dic As Object, ky As String

    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("Sheet1").Range("A1:I" & Sheets("Sheet1").Range("H" & Rows.Count).End(3).Row).Value
    b = Sheets("Sheet2").Range("A1:I" & Sheets("Sheet2").Range("H" & Rows.Count).End(3).Row).Value
    ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
    ReDim d(1 To UBound(a, 1), 1 To UBound(a, 2))

    For i = 1 To UBound(b, 1)
        ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
        dic(ky) = i
    Next

    For i = 2 To UBound(a, 1)
        ky = a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 9)
        If dic.exists(ky) Then
            j = dic(ky)
            If a(i, 8) = b(j, 8) Then
                k = k + 1
                For n = 1 To UBound(a, 2)
                    c(k, n) = a(i, n)
                Next
                c(k, 8) = 0
            Else
                m = m + 1
                For n = 1 To UBound(a, 2)
                    d(k, n) = a(i, n)
                Next
                d(k, 8) = a(i, 8) - b(j, 8)
            End If
        End If
    Next

    Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(a, 2)).Value = c
    Sheets("Sheet4").Range("A" & Rows.Count).End(3)(2).Resize(m, UBound(a, 2)).Value = d
End Sub