Невозможно заполнить уникальные значения на третьем листе, сравнивая значения второго листа с первым

Question

У меня есть три листа - main, specimen и output в книге Excel. Лист main и speciment содержат некоторую информацию. Часть информации на двух листах идентична, но немногие из них - нет. Я собираюсь вставить информацию в output, которая доступна в speciment, но не в main.

Я пробовал как [в настоящее время он заполняет много ячеек, производящих дубликаты]:

Sub getData()
    Dim cel As Range, celOne As Range, celTwo As Range
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")


    For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
        For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
            If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
        Next celOne
    Next cel
End Sub

main содержит:

UNIQUE ID   FIRST NAME          LAST NAME
A0000477    RICHARD NOEL        AARONS 
A0001032    DON WILLIAM         ABBOTT 
A0290191    REINHARDT WESTER    CARLSON 
A0290284    RICHARD WARREN      CARLSON 
A0002029    RAYMOND MAX         ABEL 
A0002864    DARRYL SCOTT        ABLING 
A0003916    GEORGES YOUSSEF     ACCAOUI 

specimen содержит :

UNIQUE ID   FIRST NAME       LAST NAME
A0288761    ROBERT HOWARD    CARLISLE 
A0290284    RICHARD WARREN   CARLSON 
A0290688    THOMAS A         CARLSTROM 
A0002029    RAYMOND MAX      ABEL 
A0002864    DARRYL SCOTT     ABLING 

output должен содержать [ ОЖИДАЕМЫЙ ]:

UNIQUE ID   FIRST NAME      LAST NAME
A0288761    ROBERT HOWARD   CARLISLE 
A0290688    THOMAS A        CARLSTROM 

Как мне этого добиться?

Answer 1

Если у вас последняя версия Excel с функцией FILTER и динамическими массивами c, вы можете сделать это с помощью формулы Excel.

Я изменил ваши основные данные и данные образца в таблицы.

На листе «Вывод» вы можете ввести эту формулу в одну ячейку:

=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))

Остальные поля будут автоматически заполнены результатами.

Для решения VBA: Мне нравится использовать словари и массивы VBA для скорости.

'set reference to microsoft scripting runtime
'  or use late-binding
Option Explicit
Sub findMissing()
    Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
    Dim dN As Dictionary, dM As Dictionary
    Dim vMain As Variant, vSpec As Variant, vOut As Variant
    Dim I As Long, v As Variant

With ThisWorkbook
    Set wsMain = .Worksheets("Main")
    Set wsSpec = .Worksheets("Specimen")
    Set wsOut = .Worksheets("Output")
End With

'Read data into vba arrays for processing speed
With wsMain
    vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With

With wsSpec
    vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With

'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
    dN.Add Key:=vMain(I, 1), Item:=I
Next I

'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
    If Not dN.Exists(vSpec(I, 1)) Then
        dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
    End If
Next I

'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
    vOut(0, 1) = "UNIQUE ID"
    vOut(0, 2) = "FIRST NAME"
    vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
    I = I + 1
    vOut(I, 1) = dM(v)(1)
    vOut(I, 2) = dM(v)(2)
    vOut(I, 3) = dM(v)(3)
Next v

Dim R As Range
With wsOut
    Set R = .Cells(1, 1)
    Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))

    With R
        .EntireColumn.Clear
        .Value = vOut
        .Style = "Output"
        .EntireColumn.AutoFit
    End With
End With

End Sub

Оба показывают один и тот же результат (за исключением того, что решение для формулы не переносит заголовки столбцов; но вы можете сделать это с помощью формулы =mnTbl[#Headers] в ячейке выше исходной формулы выше).

Answer 2

Другой вариант - объединить значения каждой строки в каждом диапазоне и сохранить их в массивах.

Затем сравните массивы и выведите уникальные значения.

В этом случае ваши уникальности получаются из оценки всей строки, а не только уникального идентификатора.

Пожалуйста, прочитайте код комментарии и настроить его в соответствии с вашими потребностями.

Public Sub OutputUniqueValues()

    Dim mainSheet As Worksheet
    Dim specimenSheet As Worksheet
    Dim outputSheet As Worksheet

    Dim mainRange As Range
    Dim specimenRange As Range

    Dim mainArray As Variant
    Dim specimenArray As Variant

    Dim mainFirstRow As Long
    Dim specimenFirstRow As Long

    Dim outputCounter As Long

    Set mainSheet = ThisWorkbook.Worksheets("main")
    Set specimenSheet = ThisWorkbook.Worksheets("specimen")
    Set outputSheet = ThisWorkbook.Worksheets("output")

    ' Row at which the output range will be printed (not including headers)
    outputCounter = 2

    ' Process main data ------------------------------------

    ' Row at which the range to be evaluated begins
    mainFirstRow = 2

    ' Turn range rows into array items
    mainArray = ProcessRangeData(mainSheet, mainFirstRow)


    ' Process specimen data ------------------------------------

    ' Row at which the range to be evaluated begins
    specimenFirstRow = 2

    ' Turn range rows into array items
    specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)

    ' Look for unique values and output results in sheet
    OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray

End Sub

Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant


    Dim dataRange As Range
    Dim evalRowRange As Range

    Dim lastRow As Long
    Dim counter As Long

    Dim dataArray As Variant

    ' Get last row in sheet (column 1 = column A)
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
    ' Set the range of specimen sheet
    Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)

    ' Redimension the array to the number of rows in range
    ReDim dataArray(dataRange.Rows.Count)

    counter = 0

    ' Join each row values so it's easier to compare them later and add them to an array
    For Each evalRowRange In dataRange.Rows

        ' Use Trim function if you want to omit the first and last characters if they are spaces
        dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)

        counter = counter + 1

    Next evalRowRange

    ProcessRangeData = dataArray

End Function

Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)

    Dim specimenFound As Boolean
    Dim specimenCounter As Long
    Dim mainCounter As Long

    ' Look for unique values ------------------------------------

    For specimenCounter = 0 To UBound(specimenArray)

        specimenFound = False

        ' Check if value in specimen array exists in main array
        For mainCounter = 0 To UBound(mainArray)

            If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True

        Next mainCounter

        If specimenFound = False Then
            ' Write values to output sheet
            outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
            outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
            outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
            outputCounter = outputCounter + 1
        End If

    Next specimenCounter
End Sub