Excel VBA Самый быстрый способ найти строки повторяющихся записей в столбце

Question

Я не профессиональный программист, но в течение нескольких лет баловался.

У меня есть таблица, содержащая список чисел, предоставленных другой системой, от 0 до 90000, хранящихся в виде строк в столбце.R. Предполагается, что каждая цифра присваивается другой системой как уникальная, однако около 5% фактически используются 1 или более раз ранее.У меня нет контроля над другой системой.

Каждый месяц я добавляю около 50 номеров в этот столбец, и мне необходимо определить, существует ли какой-либо из новых номеров в списке (включая новые, добавленные), иидентифицируйте строку в электронной таблице, которая содержит первый дубликат, а затем каждый последующий дубликат.

В конечном счете мне нужно идентифицировать (например): строка 51 является первой, содержащей строку «000356», и это также появляетсяв строках 357 и 745 Выполнение поиска (в VBA) строка за строкой занимает очень много времени (в настоящее время у меня более 1000 строк).Мне нужно будет выполнить аналогичный поиск по столбцу с более чем 3000 строками.

Мое исследование показывает, что использование словарей VBA будет более быстрым способом идентификации дубликатов, однако в моей небольшой процедуре тестирования, приведенной ниже, яЯ не смог заставить его работать, более конкретно мне нужно определить, в какой строке в электронной таблице существуют повторяющиеся числа. Есть ли лучший способ добиться этого, и что можно сделать, чтобы изменить мой тестовый код ниже, чтобы сделать егоработа?

'   From Module M2A to test faster search methods
'   Needs "Microsoft Scripting Runtime" enabled

Dim shtCFYsheet As Worksheet
Dim oFound As Boolean
Dim junk, actName As String
Dim lastrowCFYsheet As Long
Dim dictA As New Scripting.dictionary
Dim keyA, keyB As Variant

Set shtCFYsheet = Worksheets("Communify Sheet")
lastrowCFYsheet = shtCFYsheet.Cells(Rows.Count, "A").End(xlUp).Row

'   Load up DictA with all the entries from Column R

For i = 2 To lastrowCFYsheet 'Row 1 contains headings
    dictA(Trim(shtCFYsheet.Cells(i, "R").Value)) = 1
Next i


For Each keyA In dictA.Keys
    junk = DoEvents()
    oFound = False 'reset the flag for the next KeyA entry

    EntryA = keyA ' Capture the DictA entry
    For Each keyB In dictA.Keys 'Search for the first DictA entry throughout the DictA dictionary
        EntryB = keyB ' Capture the DictB entry
        'Test for a match
        If Trim(EntryA) = Trim(EntryB) Then
            If oFound = True Then Debug.Print "Match:" & EntryA, EntryB, "A-row " & dictA.Item(keyA), "B-row " & dictA.Item(keyB)
            'Ignore first match as that's my own entry
            oFound = True 'Now set flag so that next entry gets flagged as a duplicate
        End If
    Next keyB
Next keyA

End Sub

Спасибо всем.Вот некоторые примеры данных с 2 дубликатами в:

2456
4863
4190
2123
5610
9061
2640
679
4702
7428
38
3082
4702
8391
8781
998
2091
3729
5610
5051
1796
3355
169
1788
8838

Answer 1

Вы можете изменить нижеприведенное и попробовать:

Option Explicit

Sub test()

    Dim LastrowS1 As Long, LastrowS2 As Long, Times As Long, i As Long
    Dim rng As Range, rngFound As Range
    Dim str As String

    'Find the last row of column A
    LastrowS1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row

    'Start Loop from the lastrow to row 1 upside down
    For i = 2 To LastrowS1
        'Give value to str
        str = Sheet1.Range("A" & i).Value
        'Find the last row of column A
        LastrowS2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
        'Set the range you want to search
        Set rng = Sheet2.Range("A2:A" & LastrowS2)
        'Count how many times str appears in rng
        Times = Application.WorksheetFunction.CountIf(rng, str)
        'If it is appears more that one time
        If Times > 0 Then
            Set rngFound = rng.Find(str)
            Sheet2.Cells(rngFound.Row, 2).Value = Sheet2.Cells(rngFound.Row, 2).Value & ", " & "Row" & " " & i
        Else
             Sheet2.Range("A" & LastrowS2 + 1).Value = str
             Sheet2.Range("B" & LastrowS2 + 1).Value = "Row" & " " & i
        End If

    Next i

End Sub

Лист 1:

Лист 2:

Answer 2

Код ниже добавляет столбец справа от листа и записывает в него номера строк.Затем он сортирует по числовым строкам в столбце R, тем самым объединяя дубликаты в последовательных строках.Столбец измененных номеров затем проверяется на наличие последовательных дубликатов, записывая их номера строк (созданные на шаге 1) в другой столбец, добавленный справа.Наконец, данные сортируются по номерам строк, восстанавливается исходная последовательность, а столбец с номерами строк удаляется.Столбец с отмеченными дубликатами остается справа.Только первое вхождение имеет список всех номеров строк, в которых существуют дубликаты.

Для проверки выполните процедуру FindDuplicates.Обратите внимание, что два перечисления в верхней части кода могут быть сброшены.NwsFirstDataRow было 3 (третий ряд сверху) в моих испытаниях.Ваши данные могут начинаться со строки 2. Столбец с числами установлен на 18 (столбец R, считая от A = 1).Вы можете указать любой другой столбец.

Option Explicit

Enum Nws                                ' Worksheet navigation
    ' 04 Mar 2019
    NwsFirstDataRow = 3                 ' assuming 2 caption rows above the data
    NwsNumber = 18                      ' column R would be 18
End Enum

Sub FindDuplicates()
    ' 04 Mar 2019

    Dim Ws As Worksheet
    Dim Rng As Range
    Dim FreeClm As Long
    Dim R As Long

    ' modify workbook definition and worksheet name as appropriate
    Set Ws = ActiveWorkbook.Worksheets("Duplicates")
    With Ws
        Set Rng = .Range(.Cells(NwsFirstDataRow, NwsNumber), _
                         .Cells(.Rows.Count, NwsNumber).End(xlUp))
        With .UsedRange
            FreeClm = .Columns.Count + .Column
        End With
        Application.ScreenUpdating = False
        WriteRowNumbers Rng, FreeClm
        SortNumbers Ws, Rng, FreeClm
        MarkDuplicates Ws, Rng, FreeClm
        SortNumbers Ws, Rng.Offset(0, FreeClm - NwsNumber), FreeClm + 1
        .Columns(FreeClm).Delete
        Application.ScreenUpdating = True
    End With
End Sub

Private Sub WriteRowNumbers(Rng As Range, _
                            C As Long)
    ' 04 Mar 2019

    Dim Arr As Variant
    Dim R As Long

    ReDim Arr(1 To Rng.Rows.Count)
    For R = 1 To UBound(Arr)
        Arr(R) = Rng.Cells(R).Row
    Next R
    Rng.Offset(0, C - NwsNumber).Value = Application.Transpose(Arr)
End Sub

Private Sub SortNumbers(Ws As Worksheet, _
                        Rng As Range, _
                        C As Long)
    ' 04 Mar 2019

    Dim SortRng As Range

    With Ws
        Set SortRng = .Range(.Cells(NwsFirstDataRow, 1), _
                             .Cells(NwsFirstDataRow + Rng.Rows.Count - 1, C))
    End With
    With Ws.Sort.SortFields
        .Clear
        .Add Key:=Rng, _
             SortOn:=xlSortOnValues, _
             Order:=xlAscending, _
             DataOption:=xlSortTextAsNumbers
    End With
    With Ws.Sort
        .SetRange SortRng
        .Header = False
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Private Sub MarkDuplicates(Ws As Worksheet, _
                           Rng As Range, _
                           C As Long)
    ' 04 Mar 2019

    Dim Spike As String
    Dim Arr As Variant
    Dim PrevNum As String, Rt As Long
    Dim R As Long

    Arr = Rng.Value
    For R = 1 To UBound(Arr)
        If Arr(R, 1) = PrevNum Then
            Spike = Spike & ", " & Ws.Cells(R + NwsFirstDataRow - 1, C).Value
        Else
            If InStr(Spike, ",") Then Ws.Cells(Rt, C + 1).Value = Spike
            Rt = R + NwsFirstDataRow - 1
            Spike = Ws.Cells(Rt, C).Value
        End If
        PrevNum = Arr(R, 1)
    Next R
End Sub

Answer 3

Код:

Option Explicit

Sub dupeRs()

    Dim i As Long, arr As Variant, tmp As Variant
    Dim dict As New Scripting.Dictionary

    With Worksheets("Communify Sheet")

        'load worksheet values into array
        arr = .Range(.Cells(1, "R"), .Cells(Rows.Count, "R").End(xlUp)).Value

    End With

    'build dictionary
    For i = 2 To UBound(arr, 1)
        If dict.exists(arr(i, 1)) Then
            tmp = dict.Item(arr(i, 1))
            ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
            tmp(UBound(tmp)) = i
            dict.Item(arr(i, 1)) = tmp
        Else
            dict.Item(arr(i, 1)) = Array(i)
        End If
    Next i

    'optionally remove all non-duplicates
    For Each tmp In dict.Keys
        If UBound(dict.Item(tmp)) = 0 Then dict.Remove tmp
    Next tmp

    'debug.print the duplicates and row numbers
    For Each tmp In dict.Keys
        Debug.Print tmp & " in rows " & Join(dict.Item(tmp), ", ")
    Next tmp

End Sub

Результаты:

005610 in rows 6, 20
004702 in rows 10, 14