VBA Transpose Cells Based On Unique Values

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
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
 

Attachments

  • data.JPG
    data.JPG
    89.1 KB · Views: 54
  • result.JPG
    result.JPG
    23.5 KB · Views: 53

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
When you run the macro, please follow the instructions in the prompts very carefully.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,034
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top