VBA для поиска чувствительных к регистру строк DUPLICATE, а не ячеек, и удаления

Question

Смотри, чтобы исправить блестящий ответ отсюда размещено ниже. Однако ответ ниже сравнивает только значения в первом столбце для каждой строки, чтобы пометить и затем удалить.

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

 tried amending the 
       IF Not .Exists(v(i,1)) Then to 
       IF Not .Exists(v(i,1)) and IF Not .Exists(v(i,2)) Then

не работает и попытался

   IF Not .Exists(v(i,1)) Then
    IF Not .Exists(v(i,2)) Then

Sub RemoveDuplicateRows()

Dim data As Range
Set data = ThisWorkbook.Worksheets("Sheet3").UsedRange

Dim v As Variant, tags As Variant
v = data
ReDim tags(1 To UBound(v), 1 To 1)
tags(1, 1) = 0 'keep the header

Dim dict As Dictionary
Set dict = New Dictionary
dict.CompareMode = BinaryCompare

Dim i As Long
For i = LBound(v, 1) To UBound(v, 1)
    With dict
        If Not .Exists(v(i, 1 And 2)) Then 'v(i,1) comparing the values in the first column
              tags(i, 1) = i
            .Add Key:=v(i, 1), Item:=vbNullString
         End If
      End With
Next i

Dim rngTags As Range
Set rngTags = data.Columns(data.Columns.count + 1)
rngTags.Value = tags

Union(data, rngTags).Sort key1:=rngTags, Orientation:=xlTopToBottom, Header:=xlYes

Dim count As Long
count = rngTags.End(xlDown).Row

rngTags.EntireColumn.Delete
data.Resize(UBound(v, 1) - count + 1).Offset(count).EntireRow.Delete

End Sub

Answer 1

В первой попытке я подумал, что решение состоит в том, чтобы использовать операторы SQL для возврата только строк DISTINCT.

Но, не поддерживая COLLATION , SQL-предложение в VBA для приблизительно имитацииповедение с учетом регистра не будет столь эффективным, как мне бы хотелось.

Сказал, что единственная альтернатива в VBA (насколько мне известно) - это итерация по набору данных.

Попробуйте использоватьследующий подпроцесс и скажите мне, как это происходит:

Код:

Sub remove_duplicates(ByVal wk_sheet As Worksheet, ByVal rng As Range)

'   +----------------------------------------------------------+
'   | DESCRIPTION:                                             |
'   |   Removes all duplicate whole rows in a range.           |
'   |   Case sensitive.                                        |
'   |                                                          |
'   | VARIABLES:                                               |
'   |   wk_sheet = Worksheet object where our data is stored.  |
'   |   rng = Range object where our data is stored.           |
'   |   arr = array to store the matrix.                       |
'   |   a = variables to store rows for comparison.            |
'   |   b = variables to store rows for comparison.            |
'   |   dirrng = string to store the refferences of rows       |
'   |            to delete.                                    |
'   |   rngc1 = string storing first column reference of       |
'   |           range.                                         |
'   |   rngc2 = string storing last column reference of        |
'   |           range.                                         |
'   |                                                          |
'   +----------------------------------------------------------+

    Dim arr As Variant, a As Variant, b As Variant
    Dim dirrng As String, rngc1 As String, rngc2 As String

    With rng
        arr = .Value
        rngc1 = Split(Mid(.Cells(1, 1).Address, 2), "$")(0)
        rngc2 = Split(Mid(.Cells(1, .columns.Count).Address, 2), "$")(0)
    End With

    For i = 1 To UBound(arr)
        a = Join(Application.WorksheetFunction.Index(arr, i, 0), "|")
        For r = 1 To UBound(arr)
            If i <> r And _
            (dirrng = "" Or _
             Not InStr(1, dirrng, _
                       rngc1 & i & ":" & rngc2 & i, vbBinaryCompare) > 0) Then
                b = Join(Application.WorksheetFunction.Index(arr, r, 0), "|")
                If a = b Then
                    If Len(dirrng) > 0 Then
                        dirrng = dirrng & "," & rngc1 & r & ":" & rngc2 & r
                    Else
                        dirrng = rngc1 & r & ":" & rngc2 & r
                    End If
                End If
            End If
        Next r
    Next i

    'Deleting all rows at once is more efficient than deleting one at time
    If Len(dirrng) > 0 Then rng.Range(dirrng).Delete Shift:=xlUp

End Sub

Тестирование:

Я сделал тестсо следующим набором данных:

ВАЖНО: Обратите внимание, что у нас есть именованный диапазон "TABLE_CONTENT", который содержит наши поля данных. Вы должны адаптировать свою версию кода, если хотите использовать всю таблицу в качестве диапазона взаимодействия и сохранить заголовки.

Затем я использовал следующее для вызова remove_duplicates подпроцесса, передаваяправильные параметры:

Sub test()
    Call remove_duplicates(ActiveSheet, ActiveSheet.Range("TABLE_CONTENT"))
End Sub

Результат:

Надеюсь, это поможет.