比较两个 Excel 工作表并提取重复数据答案

【问题标题】：Comparing two Excel Sheets and Pulling Duplicate Data比较两个 Excel 工作表并提取重复数据
【发布时间】：2017-10-01 14:29:48
【问题描述】：

目标：

搜索并比较两个字段 E 列（表 2）与 E 列（表 1）将工作表 2 中的重复值返回到工作表 3
显示和突出显示重复项突出显示工作表 1 和 2 上的值
从工作表 2 复制重复的条目，然后添加到工作表 3

如果列 E（表 2）= 列 E（表 1），则从（表 2）复制行并添加到表 3

我正在尝试比较工作簿中的两个 Excel 工作表。我想在工作表 2 和工作表 1 之间找到重复值，并在两张工作表上突出显示这些值。我知道这是一个匹配或 vlookup 函数，但添加的层是我只想将这些值从表 2 复制到表 3 以进行视觉比较。我试图创建一个宏，但这没有帮助，我正在尝试编辑它；

Sub rowContent()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long, j As Long
    Dim isMatch As Boolean
    Dim newSheetPos As Integer

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

'Initial position of first element in sheet2
newSheetPos = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    isMatch = False
    For j = 1 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
        If ws1.Cells(i, 1).Value = ws1.Cells(j, 2).Value Then
            ws1.Cells(j, 2).EntireRow.Copy ws2.Cells(newSheetPos, 1)
            isMatch = True
            newSheetPos = newSheetPos + 1
        End If
    Next j
    If isMatch = False Then newSheetPos = newSheetPos + 1
Next i
End Sub

为我的情况工作。任何帮助将不胜感激，因为我不是 Excel Guru。

【问题讨论】：

代码有什么用处？它是否运行，但没有按预期工作？它会引发错误（如果是，是什么错误/在哪里）？另外，当两张纸上的E1 相同时，它是否重复？或者 Sheet1, Col. E 中的值可以在 Sheet2 列 E 中的任何位置吗？
How do I delete duplicates between two excel sheets quickly vba的可能重复
对不起，我认为那句话写错了。列出的脚本没有任何问题。我尝试创建的宏有问题。列出的脚本是我目前正在尝试重新设计以适应我的具体情况的脚本。此脚本比较一张纸上的两列并将数据提取到第二张纸上。这不是我想要做的。我正在尝试对另一张纸上的一张纸上的信息进行 VLOOKUP 以查找重复值，然后将该行中的数据提取到第三张纸上

标签： excel vba

【解决方案1】：

你可以试试这样的……

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("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")

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("E1:E" & lr2)
For Each cell In rng
    If Application.CountIf(ws1.Range("E:E"), cell.Value) > 0 Then
        r = Application.Match(cell.Value, ws1.Range("E:E"), 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

上面的代码假设你的工作簿中有三张 Sheet1、Sheet2 和 Sheet3。

该代码将删除 Sheet1 和 Sheet2 上任何现有的单元格内部颜色，然后以红色突出显示具有重复项的行。

如果您对这些工作表应用了一些颜色格式，最好使用条件格式来突出显示重复的行，而不是通过 VBA 代码为它们着色。

【讨论】：