比较两个工作表并使用两者的重复项构建新工作表答案

【问题标题】：Compare two worksheets and built new with duplicates from both比较两个工作表并使用两者的重复项构建新工作表
【发布时间】：2020-05-01 09:26:34
【问题描述】：

我正在尝试构建一个代码来比较两个工作表并将重复项收集到另一个工作表。目标是：

检测重复
将德国工作表中的重复行复制到 Sheet1
将奥地利工作表中的重复行复制到 Sheet1 之前
继续，直到从工作表德国和奥地利到 Sheet1 列出所有重复项

我有这段代码，但问题是它只收集重复项。因此，如果我总共有 24 个重复项，我希望在 Sheet1 上查看所有来自德国和奥地利的工作表，以便能够比较所有其他信息。

我的数据在 A:K 列中。我正在按 B 列比较数据。

我当前的代码：

Sub CopyDuplicates()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr1 As Long, lr2 As Long, lc1 As Long, lc2 As Long, r As Long
Dim rng As Range, cell As Range
Application.ScreenUpdating = False

Set ws1 = Sheets("Germany")
Set ws2 = Sheets("Austria")
Set ws3 = Sheets("Sheet1")

ws3.Cells.Clear
lr2 = ws2.UsedRange.Rows.Count
lc1 = ws1.UsedRange.Columns.Count
lc2 = ws2.UsedRange.Columns.Count

ws1.UsedRange.Interior.ColorIndex = xlNone
ws2.UsedRange.Interior.ColorIndex = xlNone

Set rng = ws2.Range("B2:B" & lr2)
For Each cell In rng
    If Application.CountIf(ws1.Range("B:B"), cell.Value) > 0 Then
        r = Application.Match(cell.Value, ws1.Range("B:B"), 0)
        'ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, lc1)).Interior.Color = vbRed
        'ws2.Range(ws2.Cells(r, 1), ws2.Cells(r, lc2)).Interior.Color = vbRed
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell
ws3.Rows(1).Delete
Application.ScreenUpdating = True
End Sub

【问题讨论】：

“问题是它只收集重复” - 抱歉，有什么问题，我不明白？您不想收集重复项吗？
这是一次性的任务，还是您需要定期做的事情？您可能想考虑只添加一个列（临时或其他）来指示该行是否重复，然后对其进行过滤。
当前代码正在合并重复项。因此，如果它在两个工作表上发现重复，它只会复制一个“以显示它是重复的”。我需要一个接一个地从两个工作表中获取它们，以便以简单的方式比较所有其他数据。 cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2) 此字符串仅从一个工作表中复制一行。它应该检测重复，从工作表德国和奥地利复制。因此，工作表 Sheet1 上应该有 2 行，而不是 1 行。一个来自德国，另一个来自奥地利
您的代码只复制cell 的行，所以您还需要复制德国表的r 行吗？

标签： excel vba

【解决方案1】：

我认为您只需将下面的行添加到您的循环中。

For Each cell In rng
    If Application.CountIf(ws1.Range("B:B"), cell.Value) > 0 Then
        r = Application.Match(cell.Value, ws1.Range("B:B"), 0)
        ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, lc1)).Interior.Color = vbRed
        ws2.Range(ws2.Cells(r, 1), ws2.Cells(r, lc2)).Interior.Color = vbRed
        'added line below
        ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, lc1)).Copy ws3.Range("A" & Rows.Count).End(3)(2)
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell

【讨论】：