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

 

[jolivanes]

@D3allamerican07
Try

Sub AAAAA()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim lr As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    With sh1.Range("A1:A" & lr)
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Offset(1).SpecialCells(12).Copy
    End With
    sh2.Range("A1").PasteSpecial Transpose:=True
    sh1.ShowAllData
Application.ScreenUpdating = True
End Sub

Change references where required.

 

[ygoyal578]

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.

Thanks DanteAmor.

But code is not getting executed properly. It is taking some values of column A value to column D also. and it is not considering all the data from A2:C.

 

[ygoyal578]

@D3allamerican07
Try

Sub AAAAA()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim lr As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    With sh1.Range("A1:A" & lr)
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Offset(1).SpecialCells(12).Copy
    End With
    sh2.Range("A1").PasteSpecial Transpose:=True
    sh1.ShowAllData
Application.ScreenUpdating = True
End Sub

Change references where required.

Sorry Bro, This is transposing only column A to single row.

 

[jolivanes]

@ygoyal578.
Re: Sorry Bro, This Is transposing only column A to single row.
I sure hope so because that is what the thread starter asked for.
You should have started your own thread instead of hijacking someone else's thread.
And if you had taken the time to just read the first line of my answer in post #11, you would have noticed who it was for.

 

[jolivanes]

@*ygoyal578
If you start it before your lunch break, it might be finished when you get back.
It assumes that you have a header row (Row 1) and that the data is in the first 3 Columns (A, B and C starting at Row 2)
Result will be in Column E on down and and to the right.

Sub During_Lunch_Break()
Dim sh1 As Worksheet
Dim lr As Long, c As Range
Set sh1 = Worksheets("Sheet1")
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    With sh1.Range("A1:A" & lr)
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Offset(1).SpecialCells(12).Copy
    End With
    sh1.Cells(Rows.Count, 5).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    sh1.ShowAllData
    
    For Each c In Range("A2:A" & lr)
        With Cells(Columns(5).Find(c.Value, , , 1).Row, Range("XFD" & Columns(5).Find(c.Value, , , 1).Row).End(xlToLeft).Column)
            .Offset(, 1).Resize(, 2).Value = c.Offset(, 1).Resize(, 2).Value
        End With
    Next c
Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

the macro cannot take values from column D. just consider from A to C. before executing the macro, clean the cells from coumna E onwards. the macro takes the last row with data from column A. or something has your data. You could share your book in the cloud to review the data.

 

[ygoyal578]

@*ygoyal578
If you start it before your lunch break, it might be finished when you get back.
It assumes that you have a header row (Row 1) and that the data is in the first 3 Columns (A, B and C starting at Row 2)
Result will be in Column E on down and and to the right.

Sub During_Lunch_Break()
Dim sh1 As Worksheet
Dim lr As Long, c As Range
Set sh1 = Worksheets("Sheet1")
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    With sh1.Range("A1:A" & lr)
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Offset(1).SpecialCells(12).Copy
    End With
    sh1.Cells(Rows.Count, 5).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    sh1.ShowAllData
  
    For Each c In Range("A2:A" & lr)
        With Cells(Columns(5).Find(c.Value, , , 1).Row, Range("XFD" & Columns(5).Find(c.Value, , , 1).Row).End(xlToLeft).Column)
            .Offset(, 1).Resize(, 2).Value = c.Offset(, 1).Resize(, 2).Value
        End With
    Next c
Application.ScreenUpdating = True
End Sub

Thanks bro the code is working fine. But getting 1 duplicate in between the newly transposed data.

 

[Peter_SSs]

You should have started your own thread instead of hijacking someone else's thread.

FYI: Posting your related question in a thread that is nearly 5 years old is not considered hijacking in this forum.

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

Thanks for the additional information. Unfortunately it did not enable me to detect why my code works for my sample data but not for your data.
It would be helpful to me if you could post some small sample data (after removing or disguising any sensitive information) where my code fails with XL2BB or, as Dante suggested, uploading somewhere and providing a shared link in this thread.

 

[jolivanes]

Hi Peter_SSs
My bad. I was not aware of that. Thanks for letting me know.

@ygoyal578
Is there not a leading or trailing space involved?

 

[Fluff]

@ygoyal578
If you run this, what does the message box say?

Sub TransposeUnique()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, Mx 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)
    Mx = Application.max(Mx, Len(d(a(i, 1))))
  Next i
  MsgBox Mx
  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

It may be one of the string is too long.