Как сопоставить данные из двух таблиц, используя определенный формат

Question

Мне интересно, может ли кто-нибудь помочь мне выяснить, как сопоставить данные из двух листов в определенном формате. Вот пример данных, которые мне нужно сопоставить, включая пример, показывающий ожидаемый результат.

Обратите внимание, что UniqueToGroup_ID уникальны только для определенного перечисленного Group_ID.Как вы можете видеть, оба примера Group_ID, которые я перечислил, содержат значение UniqueToGroup_ID XSTN, которое будет возвращать два разных идентификатора результата;2306765 для Group_ID 16453 и 8272773 для Group_ID 8156705.

Я могу (болезненно) сделать это полу-вручную, с помощью комбинации Text To Columns, добавив Group_ID к UniqueToGroup_ID и NotUniqueToGroup_ID и VLOOKUP - ноэто занимает вечность, и я должен делать это часто.

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

См. Пример здесь (Dropbox)

Заранее благодарю за любые советы.

Answer 1

Сумасшедший поиск

Ссылки

Рабочая тетрадь Загрузить инструкции по сопоставлению данных из двух электронных таблиц с использованием формата_54299649.xls

Код

Sub CrazyLookup()

    Const cSheet1 As String = "Original Data"   ' 1st Source Worksheet Name
    Const cSheet2 As String = "Data To Match"   ' 2nd Source Worksheet Name
    Const cSheet3 As String = "Sample Result"   ' Target Worksheet Name
    Const cFirstR As Long = 2                   ' First Row Number
    Const cFirstC As Variant = "A"              ' First Column Letter/Number
    Const cLastC As Variant = "C"               ' Source Worksheet's Last Column
    Const cNoC As Long = 2            ' Number of Columns of Target Array/Range
    Const cDel As String = "|"                  ' Split/Join Delimiter

    Dim vnt1 As Variant   ' 1st Source Array
    Dim vnt2 As Variant   ' 2nd Source Array
    Dim vnt3 As Variant   ' Target Array
    Dim vntU As Variant   ' Unique Array
    Dim lastR1 As Long    ' Last Row Number of 1st Source Range
    Dim lastR2 As Long    ' Last Row Number of 2nd Source Range
    Dim i As Long         ' 1st Source Array Row Counter
    Dim j As Long         ' Unique Array Row Counter
    Dim k As Long         ' 2nd Source Array Row Counter

    Application.ScreenUpdating = False
    On Error GoTo ProcedureExit

    ' Write 1st Source Range to 1st Source Array.
    With ThisWorkbook.Worksheets(cSheet1)
        lastR1 = .Columns(.Cells(1, cFirstC).Column) _
                .Find("*", , -4123, , 2, 2).Row
        vnt1 = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR1, cLastC))
    End With
    ' Write 2nd Source Range to 2nd Source Array.
    With ThisWorkbook.Worksheets(cSheet2)
        lastR2 = .Columns(.Cells(1, cFirstC).Column) _
                .Find("*", , -4123, , 2, 2).Row
        vnt2 = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR2, cLastC))
    End With

    ' Resize Target Array TO 1st Source Array's rows count and TO
    ' Number of Columns of Target Array.
    ReDim vnt3(1 To UBound(vnt1), 1 To cNoC)

    ' Write First Source Array's First Column to Target Array's first column.
    For i = 1 To UBound(vnt1)
        vnt3(i, 1) = vnt1(i, 1)
    Next

    ' Write
    For i = 1 To UBound(vnt1) ' Loop through rows of 1st Source Array.
        ' Split 1st Source Array's row in 3rd column to Unique Array.
        vntU = Split(vnt1(i, 3), cDel)
        For j = 0 To UBound(vntU) ' Loop through rows of Unique Array.
            For k = 1 To UBound(vnt2) ' Loop through rows of 2nd Source Array.
                ' Match 1st Source Array's row in 2nd column TO 2nd Source
                ' Array's row in first column AND Unique Array's row TO
                ' 2nd Source Array's row in 2nd column.
                If vnt1(i, 2) = vnt2(k, 1) And vntU(j) = vnt2(k, 2) Then
                    ' Write from 2nd Source Array's row in 3rd column to
                    ' Unique Array's row.
                    vntU(j) = vnt2(k, 3)
                    Exit For ' Stop searching.
                End If
            Next
            ' Check if match was not found.
            If k > UBound(vnt2) Then vntU(j) = "NotFound"
        Next
        ' Join Unique Array's rows to Target Array's row in second column.
        vnt3(i, 2) = Join(vntU, cDel)
    Next

    With ThisWorkbook.Worksheets(cSheet3)
        ' Clear contents of Target Range columns (excl. Headers).
        .Range(.Cells(cFirstR, cFirstC), .Cells(.Rows.Count, _
                .Cells(1, cFirstC).Column + cNoC - 1)).ClearContents
        ' Copy Target Array to Target Range.
        .Cells(cFirstR, cFirstC).Resize(UBound(vnt3), UBound(vnt3, 2)) = vnt3
    End With

ProcedureExit:
    Application.ScreenUpdating = True

End Sub

Answer 2

Я создал рабочую книгу, которая, я думаю, может решить вашу проблему. Дайте мне знать, если это поможет!

https://www.dropbox.com/s/3h6mja0xtwucbr5/20180121-Matching.xlsm?dl=0

Answer 3

Вы можете создать перекрестную ссылку из двух столбцов со словарем.

Option Explicit

Sub ertgyhj()

    Dim i As Long, ii As String, gi As Long, ugi As String, nuid As Long, r As String
    Dim a As Long, itm As String, tmp As String, arr As Variant, xref As Object, results As Object
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet

    Set ws1 = Worksheets("original data")
    Set ws2 = Worksheets("data to match")
    Set ws3 = Worksheets("sample result")
    Set xref = CreateObject("scripting.dictionary")
    Set results = CreateObject("scripting.dictionary")

    'build two column cross reference dictionary
    With ws2

        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            itm = Join(Array(.Cells(i, "A").Value2, .Cells(i, "B").Value2), Chr(124))
            xref.Item(itm) = .Cells(i, "C").Value2
        Next i

    End With

    'put column header labels into results
    results.Item("image_id") = "result"

    'collect results
    With ws1

        'loop through rows
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row

            ii = .Cells(i, "A").Value2
            gi = .Cells(i, "B").Value2
            ugi = .Cells(i, "C").Value2
            tmp = vbNullString

            arr = Split(ugi, Chr(124))

            'loop through UniqueToGroup_ID and find matches
            For a = LBound(arr) To UBound(arr)
                itm = Join(Array(gi, arr(a)), Chr(124))
                If xref.exists(itm) Then
                    tmp = IIf(CBool(Len(tmp)), tmp & Chr(124), vbNullString) & xref.Item(itm)
                End If
            Next a

            'store concatenated result with image id
            results.Item(ii) = tmp

        Next i

    End With

    'post results
    With ws3

        .Cells(1, "A").Resize(results.Count, 1) = Application.Transpose(results.keys)
        .Cells(1, "B").Resize(results.Count, 1) = Application.Transpose(results.items)

    End With

End Sub