Copy, Transpose and delete Duplicate information VBA - excel

Question

I'm trying to transpose data based on the cell information from another column.
I can fairly quickly with the macro below when I only have two data that are the same. My problem is when I hit more than one data that are the same.
For example:
Clients What they want
20 B
20 C
33 B
33 C
202 A
202 B
202 C
55 A
55 C
The macro I have is this
Sub TransposeDuplciateData()
Sheets("Duplicate").Select
While Range("A2") <> ""
Range("B2").Select
ActiveCell.Resize(2, 1).Select
Selection.Copy
Sheets("Clients").Select
Range("B1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Duplicate").Select
Selection.EntireRow.Delete Shift:=xlUp
Wend
End Sub
The problem is when I hit client number 202, he wants three different things not only two.
I'm therefore looking for a macro that it would first recognize how many times the clients appear and from there copy the relevant information from column B and transpose it into my Clients sheet, then delete the entire rows from my Duplicate sheet (since I dealt with it) and move to the next clients information and do the same thing until there is no more clients information.
Here is the end results I would like it too look like
Clients Option 1 Option 2 Option 3 Option 4
20 B C
33 B C
202 A B C
55 B C

Answer 1

a possible way to achieve your desired outcome is to use a pivot table.
If you set Column A as Row, Column B as Column and values as count of Column B, you get the following output.
A B C
20 1 1
33 1 1
55 1 1
202 1 1 1
Would that help?
For a macro based solution, try the following code. It may need to be adapted to your exact need. Make also sure, column A is sorted in some kind of a way (this can also be done within the macro)
Sub remove_dub()
With Sheets("Dublicate")
Dim row_dubl As Integer
Dim row_clie As Integer
Dim col_clie As Integer
row_dubl = 1
row_clie = 1
col_clie = 2
While .Cells(row_dubl, "A") <> ""
Sheets("Clients").Cells(row_clie, "A") = .Cells(row_dubl, "A")
Sheets("Clients").Cells(row_clie, col_clie) = .Cells(row_dubl, "B")
If .Cells(row_dubl, "A") = .Cells(row_dubl + 1, "A") Then
row_clie = row_clie
col_clie = col_clie + 1
Else
row_clie = row_clie + 1
col_clie = 2
End If
row_dubl = row_dubl + 1
Wend
End With
End Sub
Best regards

Answer 2

A bit "simplified" version:
Dim c As Range
Set c = [a2]
While c > ""
While c = c(2) ' while c equals the cell below it
c.End(xlToRight)(, 2) = c(2, 2) ' get the second value below c
c(2).Resize(, 2).Delete xlShiftUp ' delete the 2 cells below c
Wend
Set c = c(2)
Wend

Answer 3

Here is a macro which creates a user defined object as a class, which has the properties of Client and a dictionary of Opts (for Option). You can easily add other properties, if you want to extend this.
Set reference to Microsoft Scripting Runtime
EDIT: Rename the class module cClient
Class Module
Option Explicit
Private pClient As String
Private pOpt As String
Private pOpts As Dictionary
Public Property Get Client() As String
Client = pClient
End Property
Public Property Let Client(Value As String)
pClient = Value
End Property
Public Property Get Opt() As String
Opt = pOpt
End Property
Public Property Let Opt(Value As String)
pOpt = Value
End Property
Public Property Get Opts() As Dictionary
Set Opts = pOpts
End Property
Public Function ADDOpt(Value As String)
If Not pOpts.Exists(Value) Then
pOpts.Add Key:=Value, Item:=Value
End If
End Function
Private Sub Class_Initialize()
Set pOpts = New Dictionary
pOpts.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'Set reference to Microsoft Scripting Runtime
Sub OrganizeClientOptions()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim cC As cClient, dC As Dictionary
Dim I As Long, J As Long
Dim V As Variant, W As Variant
'Set worksheets
Set wsSrc = Worksheets("sheet1")
On Error Resume Next
Set wsRes = Worksheets("Results")
If Err.Number = 9 Then
Worksheets.Add.Name = "Results"
End If
On Error GoTo 0
Set wsRes = Worksheets("Results")
Set rRes = wsRes.Cells(1, 1)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With
'collect the data
Set dC = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cC = New cClient
With cC
.Client = vSrc(I, 1)
.Opt = vSrc(I, 2)
.ADDOpt .Opt
If Not dC.Exists(.Client) Then
dC.Add Key:=.Client, Item:=cC
Else
dC(.Client).ADDOpt .Opt
End If
End With
Next I
'Size vRes
J = 0
For Each V In dC.Keys
I = dC(V).Opts.Count
J = IIf(J > I, J, I)
Next V
ReDim vRes(0 To dC.Count + 1, 1 To J + 1)
'headers
vRes(0, 1) = "Client"
For J = 2 To UBound(vRes, 2)
vRes(0, J) = "Option " & J - 1
Next J
'Data
I = 0
For Each V In dC.Keys
I = I + 1
vRes(I, 1) = V
J = 1
For Each W In dC(V).Opts
J = J + 1
vRes(I, J) = W
Next W
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Results