Создать уникальный список имен из 2 заданных диапазонов

Question

У меня есть этот набор кода, который работает неправильно.

Он принимает список имен из Sheets ("one") и Sheets ("two") и должен находить уникальные имена и помещать их в Sheets («три») .

• Оба списка - просто строки текста.
• Оба списка не являются последовательными, что означает, что одно имя может находиться в строке, отличной от другого диапазона. Это не в определенном порядке.

Похоже, он просто берет один диапазон полностью и делает вывод, имена не отфильтровываются.

Для этого примера у меня есть 150 имен на листе «один», и 160 имен на листе «два». Я должен видеть только около 10 уникальных значений на листе «три». Но вместо этого я получаю возвращаемое значение ровно 160.

Есть идеи?

Sub dupes()

Dim arrRanges(1) As Excel.Range
Dim dDedupe As New Scripting.Dictionary
Dim lngCounter As Long
Dim rngInspect As Excel.Range

Set arrRanges(0) = Sheets("one").Range("A2:A1000")
Set arrRanges(1) = Sheets("two").Range("A2:A1000")

For lngCounter = 0 To 1

    For Each rngInspect In arrRanges(lngCounter).cells
        If Not dDedupe.Exists(CStr(rngInspect.Value)) Then
            dDedupe.Add CStr(rngInspect.Value), dDedupe.count
        End If
    Next rngInspect

Next lngCounter

'Output
Sheets("three").Range("A2").Resize(dDedupe.count).Value = Application.Transpose(dDedupe.Keys())

End Sub

Answer 1

Исходя из формулировки вопроса, я предполагаю, что вы пытаетесь извлечь только имена, которые встречаются в ваших данных один раз (именно поэтому сравнение списков из 150 и 160 имен должно выводить только 10 имен, которые встречаются только один раз).

С вашим кодом все в порядке, но нигде в вашем коде вы фактически не обрабатываете / не удаляете дубликаты, попробуйте этот скорректированный код:

Sub dupes()

Dim arrRanges(1) As Excel.Range
Dim dDedupe As New Scripting.Dictionary
Dim lngCounter As Long
Dim rngInspect As Excel.Range
Dim strKey As String

Set arrRanges(0) = Sheets("one").Range("A2:A" & Sheets("one").Cells(Rows.Count, 1).End(xlUp).Row)
Set arrRanges(1) = Sheets("two").Range("A2:A" & Sheets("two").Cells(Rows.Count, 1).End(xlUp).Row)

For lngCounter = 0 To 1

    For Each rngInspect In arrRanges(lngCounter).Cells
        strKey = CStr(rngInspect.Value)
        If dDedupe.Exists(strKey) Then
            dDedupe(strKey) = dDedupe(strKey) + 1
        Else
            dDedupe.Add strKey, 1
        End If
    Next rngInspect

Next lngCounter

For Each Key In dDedupe.Keys()
    If dDedupe(Key) > 1 Then dDedupe.Remove Key
Next Key
'Output
Sheets("three").Range("A2").Resize(dDedupe.Count).Value = Application.Transpose(dDedupe.Keys())

End Sub

Эта подпрограмма будет подсчитывать вхождения каждогоname, а затем удалите все имена, встречающиеся более одного раза.

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