VBA Transpose Cells Based On Unique Values

[roykana]

Dear All master,

Please help with vba code, I want input range with inputbox and output range with inputbox.

The data is on the db sheet in column E & F which I marked in yellow and the results

I want are in the results sheet in columns A, B, C. I want a very fast vba code because the data records are thousands.

This is my link : VBA Transpose Cells Based On Unique Values.xlsm
file

Thanks

roykana

 

[alansidman]

Have you looked at Power Pivot and building a measure to concatenate the results

Look at this link: Excel: Reporting Text in a Pivot Table - Strategic Finance

You can get the expected results with this simple formula.

 

[roykana]

When you run the macro, please follow the instructions in the prompts very carefully.

Option Explicit
Sub CopyUniques()
    Dim lRow As Long, arr As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, dic As Object, inRng As Range, outRng As Range, x As Long: x = 2
    Sheets("DB").Activate
    Set inRng = Application.InputBox("Select a range of ID's in column E.", Type:=8)
    Sheets("RESULT").Activate
    Columns("A:C").ClearContents
    Set outRng = Application.InputBox("Select a single cell in column A.", Type:=8)
    With Application
       .ScreenUpdating = False
       .Calculation = xlCalculationManual
       .EnableEvents = False
    End With
    Set srcWS = Sheets("DB")
    Set desWS = Sheets("RESULT")
    arr = inRng.Cells(1).Resize(inRng.Rows.Count, 2).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr) To UBound(arr)
        If Not dic.exists(arr(i, 1)) Then
            dic.Add Key:=arr(i, 1), Item:=arr(i, 2)
        End If
    Next i
    outRng.Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.keys, dic.items))
    dic.RemoveAll
    For i = LBound(arr) To UBound(arr)
        If i <= UBound(arr) - 1 Then
            If arr(i, 1) <> arr(i + 1, 1) Then
                If Not dic.exists(arr(i, 1)) Then
                    dic.Add Key:=arr(i, 1), Item:="x"
                End If
            Else
                If Not dic.exists(arr(i, 1)) Then
                    dic.Add Key:=arr(i, 1), Item:=arr(i + 1, 2)
                End If
            End If
        Else
            If Not dic.exists(arr(i, 1)) Then
                dic.Add Key:=arr(i, 1), Item:="x"
            Else
                dic.Item(arr(i, 1)) = arr(i, 2)
            End If
        End If
    Next i
    outRng.Offset(, 2).Resize(dic.Count).Value = Application.Transpose(dic.items)
    desWS.Columns("C").Replace "x", "", xlWhole, , False
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Dear Mr. mumps,

Sorry, I can reply now
Thank you very much. the code you provide works perfectly.

Thanks
roykana

 

[mumps]

You are very welcome.