VBA自动过滤复制值，去重并粘贴到其他工作表中

Posted 2023-04-19

【中文标题】VBA自动过滤复制值，去重并粘贴到其他工作表中

【英文标题】：VBA Autofilter copy values, deduplicate and paste in other sheet

【发布时间】：2021-02-19 16:23:44

【问题描述】：

我想从 Sheet1 中复制不在 Sheet2 中的“C”列中的值。由于循环太慢，我添加了带有 X 缺失行的 vlookup 标记。然后我使用值 X 进行自动过滤，并从 C 列复制值并将其粘贴到 A 列的文件底部。我想在那里粘贴重复数据删除的值。有没有办法在粘贴到新工作表之前删除重复值？

我的代码目前处理所有值：

Sub Copy_Value()

Dim Con As Worksheet
Dim Des As Worksheet
Dim Test As Worksheet
Dim Lastcol As Integer
Dim Lastrow As Integer
Dim Lastrow2 As Integer
Dim i As Long

Application.EnableEvents = False
Application.ScreenUpdating = False
Lastrow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "C").End(xlUp).Row


Set Res = ThisWorkbook.Sheets("Sheet2")
Set Con = ThisWorkbook.Sheets("Sheet1")
Set copyRange = Con.Range("C2:C" & Lastrow)

Con.Range("L1").AutoFilter Field:=12, Criteria1:="X"
Lastrow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row

copyRange.SpecialCells(xlCellTypeVisible).Copy Res.Range("A" & Lastrow2 + 1)


End Sub

谢谢

【参考方案1】：

RemoveDuplicates 是一个运行速度非常快的 VBA 函数，可能是适合您特定情况的解决方案。根据我们当前代码的逻辑（使用 Sheet1 上 Col L 中的“X”进行过滤），下面的代码实现了您想要的。

Option Explicit
Sub Copy_Value()
Dim LastRow As Long, PasteRow As Long
Application.ScreenUpdating = False

LastRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
PasteRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheet1.Columns(12).AutoFilter 1, "X"

Sheet1.Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
Sheet2.Cells(PasteRow, 1)

LastRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row

With Sheet2.Range("A" & PasteRow & ":A" & LastRow)
    .RemoveDuplicates 1, xlNo    '<~~ xlNo = no header
End With

Sheet1.AutoFilterMode = False
End Sub