Excel/VBA 从多个工作表中删除重复行

Question

目前，我从我们的一个数据库中收到每月转储，其中包含我们所有有效的公共交通订阅。将这些上传到 SAP 是我的任务，但只有与上个月不同的值。因此，应该选择所有新订阅，以及与上个月相比，不同列之一中的值之一不同的所有订阅。如果行完全一样，我就不需要了。

我收到的文件包含 7 列，A 列包含每个员工的唯一键。

我想使用 VBA 比较两个 excel 文件，方法是将上个月的文件粘贴到 Sheet1，将本月的文件粘贴到 Sheet2。我想找到那些相等的行并将它们从Sheet2 中删除。

我已经找到了一些执行此操作的 VBA 代码示例，但似乎没有任何工作正常。下面这个是我用的最后一个，下面这行代码Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)出现语法错误。

Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
Dim strValueA As String


keyColA = "A"
keyColB = "B"

intRowCounterA = 1
intRowCounterB = 1

Set wsA = Worksheets("Sheet1")
Set wsB = Worksheets("Sheet2")

Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    intRowCounterB = 1
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    strValueA = rngA.Value
    Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value
        Set rngB = wsB.Range(keyColB & intRowCounterB)
        If strValueA = rngB.Value Then
             'Code to delete row goes here, but I'm not sure exactly'
             'what it is.'
             wsB.Range(Rows(intRowCounterB)).EntireRow.Delete
             intRowCounterB = intRowCounterB - 1
        End If
        intRowCounterB = intRowCounterB + 1
    Loop
    intRowCounterA = intRowCounterA + 1
Loop

结束子

有什么想法吗？

尼克

Answer 1

下面的代码在Sheet2 中查找来自Sheet1 的重复行。它将Sheet1.Row(id) 连接中的所有行值与Sheet2.Row(id) 连接中的所有行值进行比较

最后，它将重复项移动到名称模式为"Sheet2 Dupes - yyyymmdd-hhmmss"（当前日期时间）的新工作表

Public Sub RemoveDuplicateRows()
    Dim ur1 As Range, ur2 As Range, dupeRows As Range
    Dim r1 As Range, s1 As String, r2 As Range, s2 As String

    Set ur1 = Worksheets("Sheet1").UsedRange.Rows
    Set ur2 = Worksheets("Sheet2").UsedRange.Rows  'Find duplicates from Sheet1 in Sheet2

    Set dupeRows = ur2(Worksheets("Sheet2").UsedRange.Rows.Count + 1)
    For Each r1 In ur1
        s1 = Join(Application.Transpose(Application.Transpose(r1)))
        For Each r2 In ur2
            s2 = Join(Application.Transpose(Application.Transpose(r2)))
            If s1 = s2 Then
                If Intersect(dupeRows, r2) Is Nothing Then
                    Set dupeRows = Union(dupeRows, r2)
                End If
            End If
        Next
    Next

    Dim wb As Workbook, wsDupes As Worksheet    'Move duplicate rows to new Sheet
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set wsDupes = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsDupes.Name = "Sheet2 Dupes - " & Format(Now, "yyyymmdd-hhmmss")
    dupeRows.Copy
    With wsDupes.Cells(1)
        .PasteSpecial xlPasteAll
        .PasteSpecial xlPasteColumnWidths
        .Select
    End With
    dupeRows.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub