Question

我正在尝试比较两张工作表并将重复数据复制到新工作表中。

这是我想要做的：

新工作表= sheet3

如果 B 列 (sheet1) = B 列 (sheet2)

然后将sheet1列A复制到F到sheet3列A到F，并将sheet2列A复制到Q到sheet3列G列到W。

基本上我想在sheet3中的sheet2数据旁边复制和粘贴重复的sheet1数据。而且 B 列（sheet1）可以与多个 B 列（sheet2）匹配。所以sheet1中的数据可能需要多次复制。

以下是我目前拥有的代码，它只能将重复数据从sheet2复制到sheet3。

set.seed(100)
df <- data.frame(column1 = runif(62500),
                 column2 = runif(62500),
                 column3 = runif(62500))


matrix_c3 <- matrix(data = df$column3, nrow = 250, byrow = F)

我还是 VBA 初学者，非常感谢您的帮助。


Sub CopyDuplicates()
MsgBox “Process begin now. if you cannot see any result after processing, it means there is no duplicate data between two sheets.”
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("B1: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)
        cell.EntireRow.Copy ws3.Range("A" & Rows.Count).End(3)(2)
    End If
Next cell
ws3.Rows(1).Delete
Application.ScreenUpdating = True
MsgBox “Process finished”
End Sub

Answer 1

考虑使用 Dictionary Object 作为查找。

更新 - 多对多匹配

Option Explicit
Sub CopyDuplicates()
    MsgBox "Process begin now. if you cannot see any result after processing, " & _
           "it means there is no duplicate data between two sheets."
    
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
    Dim ar As Variant, i As Long
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")
    ws3.Cells.Clear

    lr1 = ws1.UsedRange.Rows.Count
    lr2 = ws2.UsedRange.Rows.Count
    ws1.UsedRange.Interior.ColorIndex = xlNone
    ws2.UsedRange.Interior.ColorIndex = xlNone

    ' build dictionary from sheet2 col B
    Dim dict, key As String
    Set dict = CreateObject("Scripting.Dictionary")
    
    For r = 1 To lr2
        key = Trim(ws2.Cells(r, "B"))
        If Len(key) > 0 Then
            If dict.exists(key) Then
                dict(key) = dict(key) & ";" & r
            Else
                dict.Add key, r
            End If
        End If
    Next

    Application.ScreenUpdating = False
    r3 = 1 ' sheet3
    ' scan sheet 1 looking for to match with sheet 2
    For r = 1 To lr1
        key = Trim(ws1.Cells(r, "B"))
        If dict.exists(key) Then
            ' copy multiple matches
            ar = Split(dict(key), ";")
            For i = LBound(ar) To UBound(ar)
                ws1.Range("A" & r).Resize(1, 6).Copy ws3.Range("A" & r3) ' A:F
                ws2.Range("A" & ar(i)).Resize(1, 17).Copy ws3.Range("G" & r3) ' A:Q
                r3 = r3 + 1
            Next
        End If
    Next
   
    Application.ScreenUpdating = True
    MsgBox "Process finished"
End Sub

比较两个工作表并将重复数据复制到新工作表

1 个答案: