Question

我正在尝试在VBA中编写一个宏来比较两个不同列中的值，找到不匹配，然后将不匹配值的整行复制并粘贴到新工作表中。我的代码如下。

我的代码可以使用各个值（我在下面注释掉）进行此操作，但是当我尝试复制并粘贴整行时，就会出现问题。

Public Sub CompareNumber(sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet)

Dim lr1 As Long, lr2 As Long, rng1 As Range, rng2 As Range, c As Range

lr1 = sh1.Cells(Rows.Count, 2).End(xlUp).Row 'Get the last row with data for both list sheets
lr2 = sh2.Cells(Rows.Count, 2).End(xlUp).Row


Set rng1 = sh1.Range("B2:B" & lr1) 'Establish the ranges on both sheets
Set rng2 = sh2.Range("B2:B" & lr2)


    For Each c In rng1 'Run a loop for each list, ID mismatches and paste to sheet 3.

        If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then

            c.EntireRow.Copy sh3.Range("A" & Rows.Count).EntireRow.End(xlUp)(2)
            'sh3.Cells(Rows.Count, 2).End(xlUp)(2) = c.Value

        End If
    Next

    For Each c In rng2

        If Application.CountIf(rng1, c.Value) = 0 Then

            c.EntireRow.Copy sh3.Range("A" & Rows.Count).EntireRow.End(xlUp)(2)
            'sh3.Cells(Rows.Count, 2).End(xlUp)(2) = c.Value

        End If
    Next

End Sub

非常感谢任何帮助！

Answer 1

尝试＆＃34; sh1.rows（c1.row）.EntireRow.Copy sh3.Range（＆＃34; A＆＃34;＆amp; Rows.Count）.EntireRow.End（xlUp）（2）＆＃34; 代替＆＃34; c.EntireRow.Copy sh3.Range（＆＃34; A＆＃34;＆amp; Rows.Count）.EntireRow.End（xlUp）（2）＆＃34;

这可能有用

Answer 2

在源数据中，ColumnA是否始终填充？如果不是这样会在将行粘贴到sh3时导致问题 - colA中的空单元格将导致下一个粘贴的行覆盖前一行。

这样的东西更安全一些（加上一点点重构来抽象出重复的循环）：

Public Sub CompareNumber(sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet)

    Dim rng1 As Range, rng2 As Range, rngDest As Range

    'Establish the ranges on both sheets
    Set rng1 = sh1.Range(sh1.Range("B2"), sh1.Cells(Rows.Count, 2).End(xlUp))
    Set rng2 = sh2.Range(sh2.Range("B2"), sh2.Cells(Rows.Count, 2).End(xlUp))
    Set rngDest = sh3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

    CopyMismatches rng1, rng2, rngDest
    CopyMismatches rng2, rng1, rngDest

End Sub

Private Sub CopyMismatches(rngSrc As Range, rngMatch As Range, rngDest As Range)
    Dim c As Range
    For Each c In rngSrc
        If Application.CountIf(rngMatch, c.Value) = 0 Then
            c.EntireRow.Copy rngDest
            Set rngDest = rngDest.Offset(1, 0) '<< safer if could be empty colA values
        End If
    Next
End Sub

比较两列，查找不匹配并使用VBA粘贴新工作表中的整行

2 个答案: