VBA - Удалить дубликаты в столбце FILTERED

Question

Я ищу быстрый способ удаления дубликатов в определенном столбце, но только в отфильтрованном диапазоне. Поэтому в основном я бы хотел, чтобы он удалял только видимые повторяющиеся значения, но остальное оставалось «нефильтрованным и скрытым».

У меня есть этот кусок кода и понятия не имею, как не изменить это сделать так:

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

Не могли бы вы помочь? Есть ли простой способ редактировать существующий код для этого?

* Например:

• Колонка A = Continent
• Колонка B = Страна
• Колонка C = Город

Если я фильтровать страну Индия (цв B) I см. различные города, повторяющиеся много раз (col C). Я хотел бы удалить дубликаты и посмотреть только один из каждого города. Тем не менее, я не хочу, дубликаты будут удалены для других стран. *

Answer 1

Вы можете удалить дубликаты для всех комбинаций Континент-Country-Сити без фильтрации, указав все 3 в ваших RemoveDuplicates аргументов. Это не совсем ответ на ваш вопрос, но это может быть решение, которое вам нужно с меньшим шагом.

Для примера со столбцами A, B и C, как континент, страна и город, как о следующем:

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

Обратите внимание на Array часть определяет столбцы 1, 2, и 3 из диапазона , который будет искать дубликаты во всех трех столбцах (вместо всего столбца 3 из вашего существующего кода).

Я бы предложил проверить это на копии ваших данных, поскольку макросы не позволяют «отменить».

Вот скриншот образца. Исходный список находится справа, и полученный список находится слева (в столбцах A-C). Обратите внимание, «Лондон» и «Бирмингем»:

Answer 2

Вы можете быть после SpecialCells(xlCellTypeVisible) свойства Range объекта. Таким образом, ваш код может быть:

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

Это оставляет пустые строки, хотя после удаления фильтра. Единственным другим способом, который я знаю (который не оставляет пустые строки), является удаление дубликатов с помощью вашей собственной процедуры поиска дубликатов. Свойство 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