在Excel中查找重复值并使用VBA将行导出到另一个工作表

Question

我是VBA剧本的新手......我想做的是：

• 检查MS Excel文件中重复值的列
• 如果存在重复项，则将包含重复值的行复制到另一个工作表...

例如，我有一张内容为1的sheet1：

我想浏览A列中的内容，并将A列中包含重复值的行导出到新工作表中：

在搜索和编辑一些VBA脚本后，我想出了这段代码：

Sub FilterAndCopy()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngCell As Range, _
    rngMyData As Range
Dim lngMyRow As Long

Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Set rngMyData = wstSource.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

Application.ScreenUpdating = False

For Each rngCell In rngMyData
    If Evaluate("COUNTIF(" & rngMyData.Address & "," & rngCell.Address & ")") > 1 Then
        lngMyRow = wstOutput.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wstSource.Range("A" & rngCell.Row & ":D" & rngCell.Row).Copy _
            Destination:=wstOutput.Range("A" & lngMyRow & ":D" & lngMyRow)
    End If
Next rngCell

Application.ScreenUpdating = True
End Sub

这是正确的代码吗？它可以被优化为更快吗？

我有80.000条记录可以使用它...

Answer 1

编辑：添加了另一个替代代码（请参阅＆＃34;第二代码＆＃34;），这应该更快，更快

尝试这些优化

第一个代码：

Option Explicit

Sub FilterAndCopy()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range

Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")

Application.ScreenUpdating = False

With wstSource
    Set rngMyData = .Range("A1:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)

With helperRng
    .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1)
    .ClearContents
End With

Application.ScreenUpdating = True

End Sub

＆＃34;第二个代码＆＃34;

Option Explicit

Sub FilterAndCopy2()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range, _
    unionRng As Range
Dim i As Long, iOld As Long

Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
    Set rngMyData = .Range("A1:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With

With rngMyData
    Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
    Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With

With helperRng
    .FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
    .Value = .Value
End With

With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
    .Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
    i = .Rows(1).Row 'start loop from data first row
    Do While i < .Rows(.Rows.Count).Row
        iOld = i 'set current row as starting row
        Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
            iOld = iOld + 1
        Loop

        If iOld - i > 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
        i = iOld + 1
    Loop
    Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
    wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
    .Sort key1:=.Columns(4), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 2

有很多方法可以做到这一点。为了使它更简单，我尝试仅改变你的循环。 PFB改变了代码 -

For Each rngCell In rngMyData
'''    If Evaluate("COUNTIF(" & rngMyData.Address & "," & rngCell.Address & ")") > 1 Then
'''        lngMyRow = wstOutput.Cells(Rows.Count, "A").End(xlUp).Row + 1
'''        wstSource.Range("A" & rngCell.Row & ":D" & rngCell.Row).Copy _
'''            Destination:=wstOutput.Range("A" & lngMyRow & ":D" & lngMyRow)
'''    End If

   If WorksheetFunction.CountIf(rngMyData, rngCell.Value) > 1 Then

        wstOutput.Range("A100000").End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value

   End If


Next rngCell