在Excel中找到重复的值，并使用VBA将行导出到另一个工作表 [英] Find Duplicate Values In Excel and Export Rows to another sheet using VBA

问题描述

我是VBA脚本的新手...我要做的是：

• 检查列中的重复值MS Excel文件


• 如果存在重复项，则将包含重复值的行复制到另一个工作表...

例如，我有一个包含内容的sheet1：

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

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

  Sub FilterAndCopy（）
 
 Dim wstSource As Worksheet _ 
 wstOutput As Worksheet 
 Dim rngCell As Range，_ 
 rngMyData As Range 
 Dim lngMyRow As Long 
 
设置wstSource =工作表（Sheet1）
设置wstOutput = Worksheets（Sheet2）
设置rngMyData = wstSource.Range（A1：A&范围（A& Rows.Count）.End（xlUp）.Row）
 
 Application.ScreenUpdating = False 
 
每个rngCell在rngMyData 
如果评估（COUNTIF（& rngMyData.Address&，& rngCell.Address））> 1然后
 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条记录可以通过...

解决方案

编辑：添加另一个替代代码（请参阅第二个代码），这应该要快得多，

尝试这些优化

第一个代码：

  Option Explicit 
 
 Sub FilterAndCopy（）
 
 Dim wstSource As Worksheet _ 
 wstOutput As Worksheet 
 Dim rngMyData As Range，_ 
 helperRng As Range 
 
设置wstSource = Worksheets（Sheet1）
设置wstOutput =工作表（Sheet2）
 
 Application.ScreenUpdating = False 
 
与wstSource 
设置rngMyData = .Range（A1：D& .Range（A& .Rows.Count）.End（xlUp）.Row）
结束使用
设置helperRng = rngMyData.Offset（，rngMyData.Columns.Count + 1）.Resize（，1）
 
与helperRng 
 .FormulaR1C1 == if（countif C1，RC1）> 1，，1）
 .Value = .Value 
 .SpecialCells（xlCellTypeBlanks）.EntireRow.Copy目的地：= wstOutput.Cells（1，1）
 .ClearContents 
结束
 
 Application.ScreenUpdating = True 
 
 End Sub 
  

第二个代码

  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 
 
设置wstSource = Worksheets （Sheet1）
设置wstOutput =工作表（Sheet2）
 
 Application.ScreenUpdating = False 
 Application.Calculation = xlCalculationManual 
带有wstSource 
设置rngMyData = .Range（A1：D& .Range（A& .Rows.Count）.End（xlUp）.Row）
结束
 
用rngMyData 
设置helperRng = .Offset（，rngMyData。 Columns.Count  -  1）.Resize（，1）
设置unionRng = .Cells（1000,1000）'设置要与Union方法一起使用的helper单元格，以防止它第一次失败
结束与
 
与helperRng 
 .FormulaR1C1 == row（）'标记带有广告升序号（其自己的行号）的行
 .Value = .Value 
结束
 
使用rngMyData.Resize（，rngMyData.Columns.Count + 1）'enclose帮助列
 .Sort key1：=。列（1），Order1： = xlAscending，Orientation：= xlTopToBottom，Header：= xlNo'排序数据以使所有相同的列A值逐个分组
i = .Rows（1）.Row'从数据第一行开始循环
做i< .Rows（.Rows.Count）.Row 
 iOld = i将当前行设置为起始行
尽可能.Cells（iOld + 1，1）= .Cells（iOld，1）'循环直到具有不同值的第一个单元格
 iOld = iOld + 1 
循环
 
如果iOld  -  i& 0然后将unionRng = Union（unionRng，.Cells（i，1）.Resize（iOld  -  i + 1））'如果使用current值找到多个单元，则将其添加到UnionRng范围
i = iOld + 1 
循环
相交（unionRng，rngMyData）.EntireRow.Copy目的地：= wstOutput.Cells（1，1）'通过Intersect方法摆脱帮助单元格
 wstOutput.Columns（helperRng.Column）.Clear'deleteHelper列粘贴在wstOutput表
 .Sort key1：=。列（4），Order1：= xlAscending，Orientation：= xlTopToBottom，Header：= xlNo 'wstSource中的数据排序返回
结束
 helperRng.Clear'deletehelper列，不再需要
 
 Application.Calculation = xlCalculationAutomatic 
 Application.ScreenUpdating = True 
 
 End Sub 
  

I'm new to VBA scripts... What I'm trying to do is:

• check column for duplicate values in MS Excel file
• If duplicates are present, then copy rows containing duplicate values to another worksheet...

For example I have a sheet1 with content:

I want to go through the contents in column A and export rows containing duplicate values in column A to new sheet :

after searching and editing some VBA Scripts i came up with this code:

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

Is this correct code? can it be optimized to be faster?

I have 80.000 records to go through with it...

解决方案

edit: added another alternative code (see "2nd code"), which should be much, much faster

try these optimization

1st code:

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

"2nd code"

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

这篇关于在Excel中找到重复的值，并使用VBA将行导出到另一个工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！