Question

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

检测重复
将重复的行从工作表德国复制到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

Answer 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

比较两个工作表并使用两个表中的重复项新建

1 个答案: