Transpose a single column to a single row with duplicates removed

[ggilzow]

I am new to VBA coding and am trying to write a VBA code to transpose a single column to a single row with duplicates removed. This length of the list can vary.

In column B contains
1
1
2
3
4
3

I would like to transpose starting at "F1" and the row would look like this
F1 G1 H1
1 2 3

What VBA code can accomplish this?

[antoka05]

If you have your data in 'A' column (data has to start from second row) you could use this macro:

Sub Macro1()
   Application.ScreenUpdating = False
   With ThisWorkbook.ActiveSheet
      .Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=.Range("F1"), Unique:=True
      lastrow = .Cells(Rows.Count, "f").End(xlUp).Row
      .Range("f2:f" & lastrow).Copy
      .Range("g1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=True
      .Columns("f").Delete
   End With
   Application.ScreenUpdating = True
End Sub

Regards,
Antonio

[ggilzow]

Works good. Only 1 slight problem for some reason it is not copying A1 cell. If the column A has values as such
1
2
1
3
4

It will transpose to 2 3 4 and leaves out 1.

[antoka05]

May be you need to delete previous data that are in f1,g1, etc.:

Sub Macro1()
   Application.ScreenUpdating = False
   With ThisWorkbook.ActiveSheet
      .Range("a1").Offset(, 5).Resize(, Columns.Count - 5).ClearContents
      .Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=.Range("F1"), Unique:=True
      lastrow = .Cells(Rows.Count, "f").End(xlUp).Row
      .Range("f2:f" & lastrow).Copy
      .Range("g1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=True
      .Columns("f").Delete
   End With
   Application.ScreenUpdating = True
End Sub

Regards,
Antonio

[Obsessed]

Try, Assuming column B:

Sub TransposeUniqueValues()

Dim LR As Long

Columns("B").RemoveDuplicates Columns:=1, Header:=xlNo

LR = Range("B" & Columns("B").Rows.Count).End(xlUp).Row

Range("B1:B" & LR).Copy
Range("F1").PasteSpecial Paste:=xlPasteValues, Transpose:=True

End Sub

[ggilzow]

Thank you Obsessed this will work.

Thank you Antonio for your help.

G²

[AB33]

Another one

Sub mitranspose()
Dim x, i&

x = Range("B2").CurrentRegion

With CreateObject("Scripting.Dictionary")
    .comparemode = 1
    For i = 1 To UBound(x)
        If Not .exists(x(i, 1)) Then .Item(x(i, 1)) = Empty
    Next i
    
    Range("F1").Resize(, .Count).Value = .Keys

End With

End Sub