Macro to remove duplicates and sort the data in a specific way

[koskesh]

Hi, I need help from you guys.

Is it possible to create a Macro that does following:

- Finds the Column where the Data is
- Paste the values in the column next to it in following way: A; B; C; (duplicates already removed)

Attached a file for better explanation.

Thanks

 

[Deepak]

Hi,

I haven't used sorting yet so no idea about it. however following code will join them.

Function JoinUnique(myrng As Range) As String
Dim r As Range
Application.ScreenUpdating = False

With CreateObject("scripting.dictionary")
    For Each r In myrng
        If Len(r) > 0 And Not .Exists(r.Value) Then .Add r.Value, 1
    Next
JoinUnique = Join(.Keys, ",")
End With

Application.ScreenUpdating = True
End Function

 

[Deepak]

One thing just clicked!!

Something like this. You are free to manipulate it.

Option Explicit

Sub Unique()
Dim r As Range, col As String
Range("A1:A18").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
Range("G2:G4").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
For Each r In Selection
    col = col & "," & r
Next
[B2] = Right(col, Len(col) - 1)
[G1].CurrentRegion.Cells.Clear
[B2].Select
End Sub

 

[koskesh]

Thank you, how do I have to change the macro if I want the macro to look in column A (not just A1:A18)
and is it possible to include empty cells in column A

For Example:

A
B
C

D

 

[Deepak]

This one!!

Option Explicit

Sub Unique1()
Dim r As Range, col As String

With ActiveSheet
.Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.[G1], Unique:=True

.Range(.[G1], .Cells(.Rows.Count, "G").End(xlUp).Address).Sort Key1:=.[G1], Order1:=xlAscending

For Each r In .[G1].CurrentRegion
    col = col & "," & r
Next

.[B2] = Right(col, Len(col) - 1)
.[G1].CurrentRegion.Cells.Clear

End With

End Sub

 

[koskesh]

Thanks Deepak, the first time it worked, second time I got this error:
Sort method of Range class failed

.Range(.[G1], .Cells(.Rows.Count, "G").End(xlUp).Address).Sort Key1:=.[G1], Order1:=xlAscending

 

[Deepak]

Thanks Deepak, the first time it worked, second time I got this error:
Sort method of Range class failed

.Range(.[G1], .Cells(.Rows.Count, "G").End(xlUp).Address).Sort Key1:=.[G1], Order1:=xlAscending

I didn't encounter any issue so far!!!

You might doing something wrong there. try this.

Option Explicit

Sub Unique2()
Dim r As Range, col As String

Application.ScreenUpdating = False

With ActiveSheet
 .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.[G1], Unique:=True
 .Range("G1:G" & .Range("G" & .Rows.Count).End(xlUp).Row).Sort Key1:=.[G1], Order1:=xlAscending

For Each r In .[G1].CurrentRegion
     col = col & "," & r
Next

 .[B2] = Right(col, Len(col) - 1)
 .[G1].CurrentRegion.Cells.Clear
End With

Application.ScreenUpdating = True

End Sub