Поиск дубликатов во всех столбцах с различными номерами строк

Question

Я новичок в VBA и пытался написать макрос для проверки дубликатов среди столбцов. У меня есть значения в столбцах от A до Z с изменяющимся номером последней строки, некоторые могут быть 5, а некоторые могут быть 10. Есть ли способ проверить, существует ли дублирующее значение среди столбцов, а затем напечатать «duplicate» в первой строке (I не имеют значений в первой строке для всех столбцов). Это нужно для изменения последней строки и номера последнего столбца.

Answer 1

Небольшое изменение идеи @error 1004

Private d As Scripting.Dictionary
Private s As String

Function Get_Dupe_Summary(rngInput As Excel.Range) as string

Dim c As Excel.Range

    Set d = New Scripting.Dictionary

    For Each c In rngInput.Cells
        If d.Exists(c.Value) Then
            Get_Dupe_Summary = Get_Dupe_Summary & _
                IIf(Len(Get_Dupe_Summary) > 0, ",", "") & _
                "Dupe : " & c & " on row " & c.Row
        Else
            d.Add c.Value, 1
        End If
    Next c

End Function

Answer 2

Вы можете попробовать:

Option Explicit

Public Sub Get_Unique_Count_Paste_Array()

    Dim Ob As Object
    Dim rng As Range
    Dim i As Long
    Dim str As String
    Dim LR As Long
    Dim Item As Variant

    With Worksheets("Sheet1")

        For i = 1 To 26

            Set Ob = CreateObject("scripting.dictionary")

            LR = .Cells(.Rows.Count, i).End(xlUp).Row

            For Each rng In .Range(Cells(2, i), Cells(LR, i))
                str = Trim(rng.Value)
                If Len(str) > 0 Then
                    Ob(str) = Ob(str) + 1
                End If
            Next rng

            For Each Item In Ob.keys

               If .Cells(1, i).Value = "" Then
                   .Cells(1, i).Value = Item

               ElseIf .Cells(1, i).Value <> "" Then
                   .Cells(1, i).Value = .Cells(1, i).Value & ", " & Item
               End If

            Next Item

        Next i

    End With

  End Sub

Отредактированная версия:

Option Explicit

Public Sub Get_Unique_Count_Paste_Array()

    Dim Ob As Object
    Dim rng As Range
    Dim i As Long
    Dim str As String
    Dim LR As Long
    Dim Item As Variant

    With Worksheets("Sheet1")

        For i = 1 To 26

            Set Ob = CreateObject("scripting.dictionary")

            LR = .Cells(.Rows.Count, i).End(xlUp).Row

            For Each rng In .Range(Cells(2, i), Cells(LR, i))
                str = Trim(rng.Value)
                If Len(str) > 0 Then
                    Ob(str) = Ob(str) + 1
                End If
            Next rng

            For Each Item In Ob.keys

               If .Cells(1, i).Value = "" And Ob(Item) > 1 Then
                    .Cells(1, i).Value = "Duplicate"
                    Exit For
               End If

            Next Item

        Next i

    End With

  End Sub