Поиск дубликатов и переименование Master / Child

Question

У меня есть некоторый код, который находит дубликаты и выделяет ячейку:

Private Sub cmdDups_Click()
Dim Rng As Range
Dim cel As Range

Set Rng = ThisWorkbook.Worksheets("data").Range(Range("C1"), ThisWorkbook.Worksheets("data").Range("C" & Rows.Count).End(xlUp))
    For Each cel In Rng
        If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
            cel.Interior.ColorIndex = 3
        End If
    Next cel
End Sub

Однако, это сбивает с толку, потому что он просто выделяет их все. Как бы я go добавил к ним подфикс, такой как MASTER и CHILD. Мастер, основанный на том, когда первый найден, и ребенок на что-нибудь после.

Возможно ли это?

Answer 1

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

Sub Test()

Dim lr As Long, x As Long, arr As Variant
Dim rng1 As Range, rng2 As Range
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With ThisWorkbook.Worksheets("data")

    'Find last used row in column C and prepare array to read through memory
    lr = .Cells(.Rows.Count, 3).End(xlUp).Row
    Set rng1 = .Range("C1:C" & lr)
    arr = rng1.Value

    'Loop over array and create a range object through Union and check against dictionary
    For x = LBound(arr) To UBound(arr)
        If WorksheetFunction.CountIf(rng, arr(x, 1)) > 1 Then
            If Not rng2 Is Nothing Then
                Set rng2 = Union(rng2, .Cells(x, 3))
            Else
                Set rng2 = .Cells(x, 3)
            End If
            If dict.exists(arr(x, 1)) Then
                arr(x, 1) = "CHILD " & arr(x, 1)
            Else
                dict(arr(x, 1)) = 1
                arr(x, 1) = "MASTER " & arr(x, 1)
            End If
        End If
    Next

    'Read back array and change cells colors
    rng2.Interior.ColorIndex = 3
    rng1.Value = arr

End With

End Sub

До:

После:

Answer 2

Вы можете попробовать что-то вроде следующего:

Option Explicit

Sub test()

    Dim LastRow As Long, i As Long
    Dim rngWhole As Range, rngSplit As Range

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Set rngWhole = .Range("A1:A" & LastRow)

        For i = 1 To LastRow

            If WorksheetFunction.CountIf(rngWhole, .Range("A" & i).Value) > 1 Then

                Set rngSplit = .Range("A1:A" & i)

                If WorksheetFunction.CountIf(rngSplit, .Range("A" & i).Value) = 1 Then
                    .Range("B" & i).Value = "MASTER"
                Else
                    .Range("B" & i).Value = "CHILD"
                End If

                .Range("A" & i).Interior.ColorIndex = 3


            End If

        Next i

    End With

End Sub

Результаты:

Примечание:

Это не самое быстрое решение.