Консолидация и суммирование значений на основе нескольких условий VBA

Question

У меня есть 3 различных шаблона данных, которые используются для различных действий. Мне нужно консолидировать данные, которые я получаю в этих 3 шаблонах, и искал более универсальный подход, но я также могу скопировать тот же макрос и настроить параметры, чтобы соответствовать всем 3 шаблонам, так что не должно быть много работы, у меня может быть пользователь сформировать и спросить пользователя, какой шаблон они используют, а затем я могу запустить один из 3 макросов. Я не очень опытен в Dictionary or Collection, поэтому не уверен, что если бы я использовал правильный вариант. Я использовал словарный подход, потому что хотел проверить, существует ли ключ, так как я ищу уникальные данные после компиляции. Я использовал словарь в словарном подходе, так как у меня есть один столбец с номером заказа, и у меня есть несколько продуктов, которые могут быть дубликатами с разными количествами. Мне требуются уникальные продукты для каждого номера заказа и дубликаты продуктов, которые мне нужны для суммирования их количества. Есть также другие данные на листе, которые мне нужно добавить обратно для каждого продукта, так что это будет означать, что в моем словаре мне нужно было объединить все столбцы после суммы количества продукта. В прошлом я делал это, когда я упорядочиваю данные и использую обратный l oop и добавляю кол-во, а также отображая дубликаты для удаления, но я хотел попробовать изучить словарь и сборник, чтобы увидеть, есть ли какое-либо увеличение скорости при стремлении данных быть более 100 000 строк и> 20 столбцов, поэтому я подумал, что это будет лучшим подходом. Я новичок в словаре, поэтому любые рекомендации будут высоко оценены.

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

Образцы данных:

Order NO | OtherData1 | OtherData2 | Product | Qty | OtherData3 | OtherData4 | OtherData5|>20col
10001    | 100        | GB         |111111111| 10  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |222222222| 100 | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |111111111| 15  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |333333333| 25  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |111111111| 20  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |444444444| 30  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |555555555| 50  | 900-001    | UK1        | Descr     |

Желаемый вывод:

Order NO | OtherData1 | OtherData2 | Product | Qty | OtherData3 | OtherData4 | OtherData5|>20col
10001    | 100        | GB         |111111111| 25  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |222222222| 100 | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |333333333| 25  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |111111111| 20  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |444444444| 30  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |555555555| 50  | 900-001    | UK1        | Descr     |

Вот мой код:

Sub AddDuplicates()

    Dim dic As Object
    Dim dic2 As Object
    Dim Contents As Variant
    Dim ParentKeys As Variant
    Dim ChildKeys As Variant
    Dim r As Long, r2 As Long
    Dim LastR As Long

    ' Create "parent" Dictionary.  Each key in the parent Dictionary will be a disntict
    ' Code value, and each item will be a "child" dictionary.  For these "children"
    ' Dictionaries, each key will be a distinct Product value, and each item will be the
    ' sum of the Quantity column for that Code - Product combination

    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare

    ' Dump contents of worksheet into array

    With ActiveSheet
        LastR = FindLastRow(ActiveSheet, 3, 21) '.Cells(.Rows.Count, 1).End(xlUp).Row
        Contents = .Range("C17:U" & LastR).value
    End With

    ' Loop through the array

    For r = 1 To UBound(Contents, 1)

        ' If the current code matches a key in the parent Dictionary, then set dic2 equal
        ' to the "child" Dictionary for that key

        If dic.exists(Contents(r, 1)) Then
            Set dic2 = dic.Item(Contents(r, 1))

            ' If the current Product matches a key in the child Dictionary, then set the
            ' item for that key to the value of the item now plus the value of the current
            ' Quantity

            If dic2.exists(Contents(r, 3)) Then
                dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, 3)) + Contents(r, 4)


            ' If the current Product does not match a key in the child Dictionary, then set
            ' add the key, with item being the amount of the current Quantity

            Else
                dic2.Add Contents(r, 3), Contents(r, 4)

            End If

        ' If the current code does not match a key in the parent Dictionary, then instantiate
        ' dic2 as a new Dictionary, and add an item (Quantity) using the current Product as
        ' the Key.  Then, add that child Dictionary as an item in the parent Dictionary, using
        ' the current Code as the key

        Else
            Set dic2 = CreateObject("Scripting.Dictionary")
            dic2.CompareMode = vbTextCompare
            dic2.Add Contents(r, 3), Contents(r, 4) 'Contents(r, 1),
            dic.Add Contents(r, 1), dic2
        End If
    Next

    Dim i As Long
    Dim tempVar As Variant
    For r = 1 To UBound(Contents, 1)
    If dic.exists(Contents(r, 1)) Then Set dic2 = dic.Item(Contents(r, 1))
    If dic2.exists(Contents(r, 3)) Then
        For i = 1 To 19
            If i <> 4 Then
                tempVar = tempVar & "|" & Contents(r, i)
                'dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, i))
            Else
                If tempVar <> Left(dic2.Item(Contents(r, 3)), Len(tempVar)) Then
                    tempVar = tempVar & "|" & dic2.Item(Contents(r, 3))
                    'dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, i))
                Else
                    'already in the right format now duplicates exit
                    tempVar = Empty
                    Exit For
                End If
            End If
            'Debug.Print tempVar
        Next i
    End If
        If tempVar <> vbNullString Then
            dic2.Item(Contents(r, 3)) = tempVar
            'Debug.Print dic2.Item(Contents(r, 3))
            tempVar = Empty
        End If
    Next r


    Worksheets.Add    'for testing to delete after
    [a1:c1].value = Array("Code", "Product", "Qty")    'for testing to delete after

    ' Dump the keys of the parent Dictionary in an array

    ParentKeys = dic.keys
     For r = 0 To UBound(ParentKeys)
        ' Write the parent Dictionary's keys (i.e., the distinct Code values) to the worksheet
        LastR = FindLastRow(ActiveSheet, 1, 21)
        Set dic2 = dic.Item(ParentKeys(r))

        Range("B" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(dic2.keys)
        Range("C" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(dic2.items)
        Dim x As Long
        Dim dictCount As Long
        dictCount = dic2.Count
        Dim maxRecords As Long
        maxRecords = 999
        For x = 1 To WorksheetFunction.RoundUp(dic2.Count / 999, 0)
            LastR = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
            If UBound(dic2.keys) > 999 Then
                If dictCount > 999 Then
                    dictCount = dictCount - 999
                Else
                    maxRecords = dictCount
                End If
                Range("A" & LastR).Resize(maxRecords, 1).value = Application.Transpose(ParentKeys(r) & "-" & x)

            Else
                Range("A" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(ParentKeys(r))
            End If
        Next x

    Next r


    ' Destroy object variables

    Set dic2 = Nothing
    Set dic = Nothing

    MsgBox "Done"

End Sub

Answer 1

Попробуйте этот код

Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, txt As String, i As Long, ii As Long

Set ws = ThisWorkbook.Worksheets("Sheet1")
Set sh = ThisWorkbook.Worksheets("Sheet2")
a = ws.Range("A1").CurrentRegion.Value

With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a, 1)
        txt = Join(Array(a(i, 1), a(i, 4)), Chr(2))
        If Not .Exists(txt) Then
            .Item(txt) = .Count + 1
            For ii = 1 To UBound(a, 2)
                a(.Count, ii) = a(i, ii)
            Next ii
        Else
            a(.Item(txt), 5) = a(.Item(txt), 5) + a(i, 5)
        End If
    Next i
    i = .Count
End With

With sh.Range("A1")
    .Resize(1, UBound(a, 2)).Value = ws.Range("A1").Resize(1, UBound(a, 2)).Value
    .Resize(1, UBound(a, 2)).Font.Bold = True
    .Offset(1).Resize(i, UBound(a, 2)) = a
    .Parent.Columns.AutoFit
End With
End Sub

Answer 2

Вы можете использовать один словарь и составной ключ Order ~ Product. Используйте словарь для суммирования количеств. При первом появлении клавиши скопируйте полную запись в выходной лист и после сканирования всех данных повторно проверьте выходные данные, чтобы обновить количество.

Option Explicit

Sub SumDuplicates()

    Dim dictQu As Object

    Dim wb As Workbook, ws As Worksheet, wsOut As Worksheet
    Dim iLastRow As Long, iOutRow As Long, iRow As Long
    Dim sOrder As String, sProduct As String, sKey As String
    Dim nQu As Single

    Set dictQu = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' Sample Data
    Set wsOut = wb.Sheets("Sheet2") ' Output

    iLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    iOutRow = 2

    For iRow = 17 To iLastRow
        sOrder = ws.Cells(iRow, "C")
        sProduct = ws.Cells(iRow, "F")
        nQu = ws.Cells(iRow, "G")

        ' create composite key
        sKey = sOrder & "~" & sProduct

        If dictQu.exists(sKey) Then
            dictQu(sKey) = dictQu(sKey) + nQu
        Else
            dictQu(sKey) = nQu
            ' copy col C to W to output
            ws.Cells(iRow, 3).Resize(1, 21).Copy wsOut.Cells(iOutRow, 3)
            iOutRow = iOutRow + 1
        End If
    Next

    ' update total
    With wsOut
    For iRow = 2 To iOutRow - 1

        sOrder = .Cells(iRow, "C")
        sProduct = .Cells(iRow, "F")
        sKey = sOrder & "~" & sProduct

        .Cells(iRow, "G") = dictQu(sKey)
    Next
    End With

    MsgBox "OK"

End Sub