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

Question

Добро пожаловать!

У меня проблема с подготовкой функции или части кода, которая обеспечивает работу с данными в структуре ниже (данные в этом формате уже хранятся в массиве):

ID Flag Company
33 AB   67345
33 ABC  53245
33 C    67345
33 AB   25897
33 A    89217
33 BC   81237
33 B    89217
33 C    89217

Цель упражнения - получить новый массив с объединенными записями на основе ключа ID + Company. Таким образом, в основном вывод должен быть:

33 ABC  67345
33 ABC  53245
33 AB   25897
33 ABC  89217
33 BC   81237

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

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

Я пробовал решение с перемещением значений из массива в другое, но все равно получаю дублированные строки, например:

33 ABC 89217
33 AB  89217
33 C   89217

Пример кода:

   For i = 1 To UBound(Array1)
        If Array1(i, 13) <> "Matched" Then
            strTestCase = Array1(i, 1) & Array1(i, 9)
            strLegalEntityType = EntityFlag(Array1(i, 5))
                For j = 1 To UBound(Array1)
                            If Array1(j, 1) & Array1(j, 9) = strTestCase Then
                                    Array1(i, 13) = "Matched"
                            End If

                            If EntityFlag(Array1(i, 5)) = EntityFlag(Array1(j, 5)) Then
                                arrTemporary1(i, 5) = EntityFlag(Array1(j, 5)) & strLegalEntityType
                                arrTemporary1(i, 5) = funcRemoveDuplicates(arrTemporary1(i, 5))
                                 arrTemporary1(i, 1) = Array1(i, 1)
                                 arrTemporary1(i, 2) = Array1(i, 2)
                                 arrTemporary1(i, 3) = Array1(i, 3)
                                 arrTemporary1(i, 4) = Array1(i, 4)
                                 arrTemporary1(i, 6) = Array1(i, 6)
                                 arrTemporary1(i, 7) = Array1(i, 7)
                                 arrTemporary1(i, 8) = Array1(i, 8)
                                 arrTemporary1(i, 9) = Array1(i, 9)
                                 arrTemporary1(i, 10) = Array1(i, 10)
                                 arrTemporary1(i, 11) = Array1(i, 11)
                                 arrTemporary1(i, 12) = Array1(i, 12)

                                 a = a + 1

                             End If


            Next j
        End If
    Next i

Answer 1

Это можно сделать в Power Query (он же Get&Transform в Excel 2016 +)

• Группировка строк по идентификатору и компании с операцией = "Все строки"
• Добавьте пользовательский столбец, чтобы преобразовать результирующую таблицу в список:
  • Формула для пользовательского столбца: Table.Column([Grouped],"Flag")
• Выберите двуглавую стрелку в верхней части столбца «Пользовательский» и значения «Извлечь» из списка, используя «none» для разделителя

Все вышеперечисленное можно сделать из пользовательского интерфейса (с ручным вводом формулы для пользовательского столбца), но вот результирующий M-код:

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", Int64.Type}, {"Flag", type text}, {"Company", Int64.Type}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"ID", "Company"}, {{"Grouped", each _, type table [ID=number, Flag=text, Company=number]}}),
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each Table.Column([Grouped],"Flag")),
    #"Extracted Values" = Table.TransformColumns(#"Added Custom", {"Custom", each Text.Combine(List.Transform(_, Text.From)), type text})
in
    #"Extracted Values"

Answer 2

Вы можете достичь этого, используя словарь.Для использования словарей необходимо добавить ссылку на Microsoft Scripting Runtime

Sub demo()
    Dim dict As New Scripting.Dictionary
    Dim arr As Variant
    Dim i As Long
    Dim tmpID As String
    Dim k
    Dim tmpFlag As String

    ' Set range to variant
    ' Update with your sheet reference and range location
    With ActiveSheet
        arr = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3))
    End With

    ' Loop through array
    For i = LBound(arr, 1) To UBound(arr, 1)
        ' Create composite ID of ID and Company
        tmpID = arr(i, 1) & "," & arr(i, 3)
        ' If it doesn't exist add to dictionary
        If Not dict.Exists(tmpID) Then
            dict.Add Key:=tmpID, Item:=arr(i, 2)
        ' If it does exist append value
        Else
            tmpFlag = StrConv(dict(tmpID) & arr(i, 2), vbUnicode)
            tmpFlag = Join(SortArrayAtoZ(Split(tmpFlag, Chr$(0), Len(tmpFlag))), "")
            dict(tmpID) = tmpFlag
        End If
    Next i

    ' Read back results
    ReDim arr(1 To dict.Count, 1 To 3)
    Dim arrCount As Long

    ' Debug.Print results can be viewed in the Immediate Window
    Debug.Print "ID", "Flag", "Company"
    For Each k In dict.Keys
        arrCount = arrCount + 1
        arr(arrCount, 1) = Split(k, ",")(0)
        arr(arrCount, 2) = dict(k)
        arr(arrCount, 3) = Split(k, ",")(1)
        Debug.Print Split(k, ",")(0), dict(k), Split(k, ",")(1)
    Next k

    ' Update with first cell of desired location of results
    With ActiveSheet
        .Cells(2, 5).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

End Sub

---

Function SortArrayAtoZ(myArray As Variant)
    Dim i As Long
    Dim j As Long
    Dim Temp

    'Sort the Array A-Z
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
            If UCase(myArray(i)) > UCase(myArray(j)) Then
                Temp = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = Temp
            End If
        Next j
    Next i

    SortArrayAtoZ = myArray
End Function