How to horizontally return looked up values from duplicates w VBA [pic]

问题

See pic related. I'm trying to return values corresponding to duplicate cells in an array ==>horizontally. So the first instance of a lookup goes in Column E, the second instance in Column F, third in G; and so-on. I can do that with an array formula for this small bit of data:

Array Formula for Duplicates

But here's the issue.

Using array formulas for 5, 10, or 15,000+ rows takes quite a bit of time. Is there a VBA solution to return values corresponding to duplicate cells in an array by columns?

回答1:

I'm sure there are very performant VBA solutions, but why not just skip all that and do it in a pivot table?

Given your data:

where the additional field 'Column 1' is built from the formula

="Payment_" & COUNTIF($A$2:A2,A2)

It's a snap to "summarize as pivot table" to this:

回答2:

Ok, here's some vba code that I did over lunch. Performs over 5000 records in less than a second.

You will need to customize in some degree to set source and target positions in your workbook.

Sub vbaJaggedPivot()


    'replace the Range with however you want to define your source range.
    SourceData = Range(Cells(2, 1), Cells(5000, 2))

    'set up a dictionary object  We'll collect the row's name as key, and use a collection of payments for the item
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    'Iterate over the spreadsheet range
    For i = 1 To UBound(SourceData)

        'add a new dictionary key and instantiate a payment collection for it if we haven't seen the current name before
        If Not dict.Exists(SourceData(i, 1)) Then
            Set paymentCol = New Collection
            paymentCol.Add SourceData(i, 2)

            dict.Add SourceData(i, 1), paymentCol

        Else

            'if we have this key, add the payment to the corresponding payment collection
            dict(SourceData(i, 1)).Add (SourceData(i, 2))
        End If


    Next i


    'identify the top left of the output area
    Dim targetRow, targetCol
    targetRow = 1
    targetCol = 5

    'some temporary placeholders for within the loop
    Dim tempArray() As Variant
    Dim key

    'iterate over the dictionary keys
    For i = 0 To dict.Count - 1

        'write out the key value to the output area
        key = dict.Keys()(i)
        Cells(targetRow + i, targetCol) = key

        'convert our collections to arrays, as these can be output with better peformance
        '      (* a 2D array would have been best, but the jagged nature of the data makes this awkward)
        ReDim tempArray(dict(key).Count - 1)
        For j = 0 To dict(key).Count - 1
            tempArray(j) = dict(key)(j + 1)
        Next j

        'write the payments out to the appropriate rows
        Range(Cells(targetRow + i, targetCol + 1), Cells(targetRow + i, targetCol + j)) = tempArray


    Next i



End Sub

来源：https://stackoverflow.com/questions/59185367/how-to-horizontally-return-looked-up-values-from-duplicates-w-vba-pic