Excel для удаления дубликатов по одному столбцу за несколько столбцов

Question

У меня есть книга Excel со многими листами (40+), каждая из которых содержит по три столбца (30+).

Моя цель - удалить дубликаты в каждом столбце, но не на основе других столбцов. Я хотел бы повторить это для всех столбцов на всех листах.

Я попытался создать макрос, но после выполнения макроса будет выбран только столбец, который я выбрал, когда я создал макрос.

Answer 1

Этот код удаляет дубликаты из каждого столбца в книге - обрабатывает каждый столбец как отдельный объект.

Sub RemoveDups() 

    Dim wrkSht As Worksheet 
    Dim lLastCol As Long 
    Dim lLastRow As Long 
    Dim i As Long 

    'Work through each sheet in the workbook. 
    For Each wrkSht In ThisWorkbook.Worksheets 

     'Find the last column on the sheet. 
     lLastCol = LastCell(wrkSht).Column 

     'Work through each column on the sheet. 
     For i = 1 To lLastCol 

      'Find the last row for each column. 
      lLastRow = LastCell(wrkSht, i).Row 

      'Remove the duplicates. 
      With wrkSht 
       .Range(.Cells(1, i), .Cells(lLastRow, i)).RemoveDuplicates Columns:=1, Header:=xlNo 
      End With 
     Next i 

    Next wrkSht 

End Sub 

'This function will return a reference to the last cell in either the sheet, or specified column on the sheet. 
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range 

    Dim lLastCol As Long, lLastRow As Long 

    On Error Resume Next 

    With wrkSht 
     If Col = 0 Then 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     Else 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row 
     End If 

     If lLastCol = 0 Then lLastCol = 1 
     If lLastRow = 0 Then lLastRow = 1 

     Set LastCell = wrkSht.Cells(lLastRow, lLastCol) 
    End With 
    On Error GoTo 0 

End Function 

Как Иисус сказал - RemoveDuplicates не будет работать в более ранних версиях. Предоставление вам двух запасных столбцов в конце каждого листа, эта версия будет работать в Excel 2003. Он использует расширенный фильтр для копирования уникальных значений в конец столбца, очищает исходный столбец и снова вставляет данные обратно.

Sub RemoveDups() 

    Dim wrkSht As Worksheet 
    Dim lLastCol As Long 
    Dim lLastRow As Long 
    Dim i As Long 

    'Work through each sheet in the workbook. 
    For Each wrkSht In ThisWorkbook.Worksheets 

      'Find the last column on the sheet. 
      lLastCol = LastCell(wrkSht).Column 

      'Work through each column on the sheet. 
      For i = 1 To lLastCol 

       'Find the last row for each column. 
       lLastRow = LastCell(wrkSht, i).Row 

       'Only continue if there's more than 1 row of data. 
       If lLastRow > 1 Then 
        With wrkSht 
         FilterToUnique .Range(.Cells(1, i), .Cells(lLastRow, i)), .Cells(1, i) 
        End With 
       End If 
      Next i 
    Next wrkSht 

End Sub 

'This function will return a reference to the last cell in either the sheet, or specified column on the sheet. 
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range 

    Dim lLastCol As Long, lLastRow As Long 

    On Error Resume Next 

    With wrkSht 
     If Col = 0 Then 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     Else 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row 
     End If 

     If lLastCol = 0 Then lLastCol = 1 
     If lLastRow = 0 Then lLastRow = 1 

     Set LastCell = wrkSht.Cells(lLastRow, lLastCol) 
    End With 
    On Error GoTo 0 

End Function 

Public Sub FilterToUnique(rSourceRange As Range, rSourceTarget As Range) 

    Dim rLastCell As Range 
    Dim rNewRange As Range 

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
    'Find the last cell and copy the unique values to the last column + 2 ' 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
    Set rLastCell = LastCell(rSourceRange.Parent) 
    rSourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rLastCell.Parent.Cells(rSourceRange.Row, rLastCell.Column + 2), Unique:=True 

    '''''''''''''''''''''''''''''''''''''''' 
    'Get a reference to the filtered data. ' 
    '''''''''''''''''''''''''''''''''''''''' 
    Set rLastCell = LastCell(rSourceRange.Parent, rLastCell.Column + 2) 
    With rSourceRange.Parent 
     Set rNewRange = .Range(.Cells(rSourceRange.Row, rLastCell.Column), rLastCell) 
    End With 

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
    'Clear the column where the data is going to be moved to. ' 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
    rSourceRange.ClearContents 

    '''''''''''''''''''''''''''''''''''''''''''''' 
    'Move the filtered data to its new location. ' 
    '''''''''''''''''''''''''''''''''''''''''''''' 
    rNewRange.Cut Destination:=rSourceTarget 

End Sub 

Answer 2

Вот несколько кодов, которые помогут вам начать работу.

Что я сделал, сначала был создан простой список с некоторыми дубликатами. Я использовал макрорекордер (Developer -> Record Macro).

Я выбрал список, а затем перешел к Data -> Remove Duplicates.

Я остановил запись, чтобы увидеть этот код:

Range("A1:A11").Select 
ActiveSheet.Range("$A$1:$A$11").RemoveDuplicates Columns:=1, Header:=xlNo 

Я приспособил .RemoveDuplicates метод к петле через рабочие листы, как например:

Sub RemoveDups() 
     Dim ws As Worksheet 
     Dim col As Range 

     For Each ws In ActiveWorkbook.Sheets 
       For Each col In ws.UsedRange.Columns 
         ws.Range(col.Address).RemoveDuplicates Columns:=1, Header:=xlNo 
       Next col 
     Next ws 

End Sub 

Я заметил, что это было бы бросить ошибку во время выполнения если в вашей книге есть пустой рабочий лист, поэтому я добавил некоторую логику, чтобы проверить пустой лист. Тест состоит из проверки используемых строк, используемых столбцов и значения ячейки A1 на листе. Если количество строк и столбцов равно 1, и ничто не находится в ячейке A1, я считаю, что лист пуст, и код пропустит его. Это совершенно необязательно, если вы уверены, что ваша книга не будет иметь пустой лист. Я просто включил его для полноты.

Sub RemoveDups() 
     Dim ws As Worksheet 
     Dim col As Range 
     Dim IsSheetEmpty As Boolean 

     IsSheetEmpty = False 

     For Each ws In ActiveWorkbook.Sheets 
       IsSheetEmpty = ws.UsedRange.Rows.Count = 1 _ 
         And ws.UsedRange.Columns.Count = 1 _ 
         And ws.Cells(1, 1).Value = "" 
       If IsSheetEmpty = False Then 
         For Each col In ws.UsedRange.Columns 
           ws.Range(col.Address).RemoveDuplicates Columns:=1, Header:=xlNo 
         Next col 
       End If 
     Next ws 

End Sub 

Метод .RemoveDuplicates был добавлен в Office 2007, если вы используете более раннюю версию, которая требует иного подхода.