(VBA) Удалить дубликаты клеток в том же регионе

Question

У меня проблема в том, что я не могу удалить дубликаты в том же разделе (то же имя в столбце B). Он должен сканировать каждый раздел и сохранять только 1-е уникальное значение из каждого раздела.

Проблема заключается в том, что он анализирует, имеют ли 2 последовательные строки одно и то же имя (что указывает на раздел), и на основании этого удаляет дубликаты. Он не анализирует каждый раздел, сравнивая, например, 1-ю строку с последней строкой, но 1 на 1, что неверно, поскольку предпоследняя или последняя строка каждого раздела может иметь дубликат на основе 1-й строки.

Answer 1

Я уверен, что вы можете найти лучший и более оптимизированный код здесь, этот выполняет свою работу:

Sub DeleteDuplicates
    Dim ColBrand As Integer, ColMil As Integer, ColColor as Integer
    Dim RowSectionStart as Integer, RowCurrent as Integer
    Dim ws As Worksheet

    Set ws = Workbooks("Classeur1").Sheets("Feuil1")

    ColBrand = 2
    ColMil = 3
    ColColor = 4
    RowCurrent = 2

    Do While ws.Cells(RowCurrent, ColBrand).Value <> ""
        ' Section change if needed
        If RowCurrent = 1 Then
            RowSectionStart = RowCurrent
        ElseIf ws.Cells(RowCurrent, ColBrand) <> ws.Cells(RowCurrent - 1, ColBrand) Then
            RowSectionStart = RowCurrent
        End If

        If RowSectionStart <> RowCurrent Then
            ' Delete duplicate in Mil column
            If Not Range(ws.Cells(RowSectionStart, ColMil), ws.Cells(RowCurrent - 1, ColMil)).Find(ws.Cells(RowCurrent, ColMil).Value) Is Nothing Then
                ws.Cells(RowCurrent, ColMil).ClearContents
            End If

            ' Delete duplicate in Color column
            If Not Range(ws.Cells(RowSectionStart, ColColor), ws.Cells(RowCurrent - 1, ColColor)).Find(ws.Cells(RowCurrent, ColColor).Value) Is Nothing Then
                ws.Cells(RowCurrent, ColColor).ClearContents
            End If
        End If
        RowCurrent = RowCurrent + 1
    Loop

    Set ws = Nothing

End Sub

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

Answer 2

Чтобы решить эту проблему, я бы создал 2 словаря:
1-й словарь (1): Ключ: Имя + Мил, Значение: на самом деле не имеет значения
2-й словарь (2): Ключ: Имя + Цвет, Значение: на самом деле не имеет значения

Вы l oop, начиная с верха / низа до низа / верха.
Для каждой строки вы проверяете, существует ли комбинация столбца B & C в словаре (1), если так-> удалить значения из ячейки (в столбце B), если не существует -> добавить новую комбинацию в словарь.

То же самое для комбинации B & D (словарь 2).

Это должно решить проблему.

Примечание:
В целях оптимизации поместите столбцы в массивы (arrColB = shtWorking.Range ("B: B")).

Вот прозрачное объяснение словарей:
https://excelmacromastery.com/vba-dictionary/

При условии, что я понял логи c дубликатов, это выглядело бы так:

Sub StackOverflow()

Dim lngI As Long
Dim lngLastRow As Long
Dim dicNameMil As Object
Dim dicNameColor As Object
Dim shtWorking As Object
Dim arrColB As Variant
Dim arrColC As Variant
Dim arrColD As Variant
Dim strKey As String

'set objects
Set shtWorking = Sheets(1)
Set dicNameMil = CreateObject("Scripting.Dictionary")
Set dicNameColor = CreateObject("Scripting.Dictionary")

lngLastRow = shtWorking.Cells(shtWorking.Rows.Count, 1).End(-4162).Row 'find last row with data/base on column A
arrColB = shtWorking.Range("B:B")
arrColC = shtWorking.Range("C:C")
arrColD = shtWorking.Range("D:D")

For lngI = 2 To lngLastRow Step 1
    'validate column C
    strKey = arrColB(lngI, 1) & arrColC(lngI, 1)
    If dicNameMil.exists(strKey) Then
       shtWorking.Range("C" & lngI).Value = ""
    Else
        dicNameMil.Add strKey, "New combination of Name and Mil"
    End If
    'Validate column D
    strKey = arrColB(lngI, 1) & arrColD(lngI, 1)
    If dicNameMil.exists(strKey) Then
       shtWorking.Range("D" & lngI).Value = ""
    Else
        dicNameMil.Add strKey, "New combination of Name and Color"
    End If
Next lngI

'set objects to nothing
Set shtWorking = Nothing
Set dicNameMil = Nothing
Set dicNameColor = Nothing

End Sub