Transpose Unique Values in column to row

[D3allamerican07]

Column A on Sheet1 has many different remarks. I need to make a unique list on Sheet2 with values from Column A on Sheet1 but post it in one row. This is the idea:

Sheet1:
Column A
1
1
2
2
2
3
3
3

Sheet2:
Column A------------Column B------------Column C
1-------------------------2----------------------3

The code I have doesn't quite work:

Sheets("Sheet1").Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

 

[Kamolga]

If you the first two rows are similar - as in your example - use code below

Sub Test()
Sheets("Sheet1").Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

else

Sub Test()
Sheets("Sheet1").Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

end if

 

[ygoyal578]

How to do the transpose 2 columns based on first column. Attaching screen short for requirement.

 

[Peter_SSs]

How to do the transpose 2 columns based on first column.

Give this a try with a copy of your data.

Sub TransposeUnique()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("C" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2) & ";" & a(i, 3)
  Next i
  With Range("E2:F2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns DataType:=xlDelimited, Semicolon:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9))
  End With
End Sub

 

[ygoyal578]

Give this a try with a copy of your data.

Sub TransposeUnique()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("C" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2) & ";" & a(i, 3)
  Next i
  With Range("E2:F2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns DataType:=xlDelimited, Semicolon:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9))
  End With
End Sub

Hi,
Thanks for the help when I run the code it is working for that particular data set. But when I increasing the count of data let say of 4K rows and data starting from A4 then the code is showing error. Attaching the error code.

 

[Peter_SSs]

Attaching the error code.

That actually does not give any details of the error other than which line it occurred on. Always a good idea to give the full error message as we well.
The most common error for that line would be if there are more than 65,000+ unique email addresses - which could not happen with 4,000 rows of data.

If you add in this line of code where shown and run the code again, what does the message box tell you?

  With Range("E2:F2").Resize(d.Count)
    MsgBox d.Count
    .Value = Application.Transpose(Array(d.Keys, d.Items))

 

[ygoyal578]

That actually does not give any details of the error other than which line it occurred on. Always a good idea to give the full error message as we well.
The most common error for that line would be if there are more than 65,000+ unique email addresses - which could not happen with 4,000 rows of data.

If you add in this line of code where shown and run the code again, what does the message box tell you?

  With Range("E2:F2").Resize(d.Count)
    MsgBox d.Count
    .Value = Application.Transpose(Array(d.Keys, d.Items))

Hello,

Attaching the error box. There are 652 unique count that MsgBox d.count is returning.

 

[DanteAmor]

Check if the following works for you.
I did a test with 2,000 unique records and 6,000 columns, that is 12 million cells.
The macro is longer, I know, the macro time for those records is 20 seconds, it's also a long time, I know.
But maybe it works for you with your data.

Sub TransposeColumns()
  Dim a As Variant, b() As Variant
  Dim dic As Object, i As Long, lin As Long, col As Long, n As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    If dic(a(i, 1)) > n Then n = dic(a(i, 1))
  Next
  n = (n * 2) + 1
  ReDim b(1 To dic.Count, 1 To n)
  dic.RemoveAll
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      lin = lin + 1
      col = 1
      b(lin, col) = a(i, 1)
    Else
      lin = Split(dic(a(i, 1)), "|")(0)
      col = Split(dic(a(i, 1)), "|")(1) + 2
    End If
    dic(a(i, 1)) = lin & "|" & col
    b(lin, col + 1) = a(i, 2)
    b(lin, col + 2) = a(i, 3)
  Next
  Application.ScreenUpdating = False
  Range("E2").Resize(dic.Count, n).Value = b
  Application.ScreenUpdating = True
End Sub

Note:
If you have any problems, write here which line the macro stops on and what the error message says. Also if possible, check which of your data the process stopped, just move the mouse over the variable "i" a number should appear, then go to your sheet and check the data in that row and the previous row. Check those data if they have anything abnormal.

 

[jolivanes]

So to whom are the answers directed?
To the thread starter(D3allamerican07) or the hijacker (*ygoyal578)?

 

[DanteAmor]

To @*ygoyal578