VBA – 删除FILTERED列中的重复项

我正在寻找一种快速的方法来删除特定列中的重复项，但只在筛选的范围内。 所以，基本上我希望它只删除可见的重复值，但留下“未过滤和隐藏”的rest。

我有这段代码，并不知道如何改变它来做到这一点：

ActiveSheet.Range("A:ZZ").RemoveDuplicates Columns:=Array(3), Header:=xlYes 

能否请你帮忙？ 有没有简单的方法来编辑现有的代码来做到这一点？

*例如：

• 列A =大陆
• B栏=国家
• C列=城市

如果我通过印度过滤国家（col B），我会看到多个城市重复多次（col C）。 我想删除重复项目，只看到每个城市之一。 但是，我不希望其他国家的副本被删除。

Answer 1

您可以通过在RemoveDuplicates参数中指定所有3来删除所有Continent-Country-City组合的重复项。 这不是完全回答你的问题，但它可能是你需要一个更less的步骤的解决scheme。

对于你的例子，列A，B和C作为大陆，国家和城市，如何：

 ActiveSheet.Range("A:C").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes 

请注意， Array部分指定了要评估的范围中的列1,2和3，它将在所有3列（而不是现有代码中的第3列）中查找重复项。

我build议在数据副本上testing这个，因为macros不允许“撤消”。

以下是一个示例的屏幕截图。 原始列表在右侧，结果列表在左侧（AC列）。 注意“伦敦”和“伯明翰”：

Answer 2

您可能在Range对象的SpecialCells(xlCellTypeVisible)属性之后。 所以你的代码可能是：

 ActiveSheet.Range("A:ZZ").SpecialCells(xlCellTypeVisible).RemoveDuplicates Columns:=Array(3), Header:=xlYes 

但是，一旦删除了filter，则会留下空行。 我知道的唯一的其他方式（不留空行）是用你自己的重复查找例程删除重复。 SpecialCells属性仍可用于仅检查过滤的数据。 像这样的东西：

 Dim uniques As Collection Dim cell As Range, del As Range Dim exists As Boolean Dim key As String Set uniques = New Collection For Each cell In ActiveSheet.Range("A:ZZ").Columns(3).SpecialCells(xlCellTypeVisible).Cells key = CStr(cell.Value2) exists = False On Error Resume Next exists = uniques(key) On Error GoTo 0 If Not exists Then uniques.Add True, key Else If del Is Nothing Then Set del = cell Else Set del = Union(del, cell) End If End If Next If Not del Is Nothing Then del.EntireRow.Delete End If 

Answer 3

也许你需要一个定制的VBA卸妆器。 尝试这个：

 Sub RemoveVisibleDupes(r As Range, comparedCols) Dim i As Long, j As Long, lastR As Long i = r.Row: lastR = r.Row + r.Rows.count - 1 Do While i < lastR For j = lastR To i + 1 Step -1 If Not (r.Rows(i).Hidden Or r.Rows(j).Hidden) And areDup(r.Rows(i), r.Rows(j), comparedCols) Then r.Rows(j).Delete lastR = lastR - 1 End If Next i = i + 1 Loop End Sub Function areDup(row1 As Range, row2 As Range, comparedCols) As Boolean Dim col For Each col In comparedCols If row1.Cells(col).Value <> row2.Cells(col).Value Then Exit Function Next areDup = True End Function 

testing

 Sub TestIt() On Error GoTo Finish Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False ' call our custom dup-remover on filtered columns A:C with comparing columns 1 and 3 RemoveVisibleDupes Sheet2.Range("A1:C" & Sheet2.Cells(Sheet2.Rows.count, 1).End(xlUp).Row), Array(1, 3) ' To use it with one column only, say 3, replace Array(1, 3) with array(3) Finish: Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True End Sub