Fjern dubletter i kolonne og sammel unikke forekomster i en strin

rækker hvor dubletter er slettes !!!
og streng med navne indsættes i D2
Der er grænser for hvor mange navne der kan vises i 1 celle

Sub SletDubletter() ' Slet i markeret kolonne
c = 3
r = Cells(65500, c).End(xlUp).Row
Range(Cells(2, c), Cells(65500, c).End(xlUp)).Select
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Cells(t2, c) = ""
End If
Next
End If
Next

Selection.Columns.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlUp

r = Cells(65500, c).End(xlUp).Row
For t = 2 To r
x = x & Cells(t, 3) & ", "
Next

Range("D2") = x
ActiveCell.Select
End Sub

Må hellere lige udtrykke mig lidt nærmere om ønsket.

1) Sorter listen (evt. alfabetisk)
2) Fjern dubletter
3) De unikke forekomster skal samles i en string.

Sorry, du svarede mens jeg skrev, så min kommentar er ikke en respons på dit indlæg :)

indsæt denne som 8 sidste linie:

Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending

Ser ud til at fungere fremragende, men fandt ud af, at det faktisk var kolonne D og ikke C.

Mit script ser sådan ud nu:
--------------------------------------------------
Sub SletDubletter() ' Slet i markeret kolonne
Sheets("Handelsoversigt").Select
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
c = 3
r = Cells(65500, d).End(xlUp).Row
Range(Cells(2, d), Cells(65500, d).End(xlUp)).Select
For t = 1 To r
If Cells(t, d) <> "" Then
For t2 = t + 1 To r
If Cells(t, d) = Cells(t2, d) Then
Cells(t2, d) = ""
End If
Next
End If
Next

Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending

r = Cells(65500, d).End(xlUp).Row
For t = 2 To r
x = x & Cells(t, 3) & ", "
Next

Range("L1") = x
ActiveCell.Select
Sheets("Kunder").Select
End Sub
--------------------------------------------------
Jeg kan ikke gennemskue om c = 3 skal ændres til d = 3

Ved du hvad begrænsningen er for én celle (altså hvor mange karakterer kan den rumme?)

variablen c får værdien 3 ( = kolonne C ) kan blot ændres til 4 = D

mener det er 1000 tegn en celle kan vise

Den skulle ændres :D Må være træt, først i bakspejlet jeg overvejede bare at prøve hehe.

Smid et svar ... tak for hjælpen - igen :D

velbekom :-)

Får en fejl nu. Kan jeg få dig til lige at se scriptet igennem en sidste gang?
Fejlen fås på linie 6 (r = Cells(65500, d).End(xlUp).Row)

Sub SletDubletter() ' Slet i markeret kolonne
Sheets("Handelsoversigt").Select
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
d = 4
r = Cells(65500, d).End(xlUp).Row
Range(Cells(2, d), Cells(65500, d).End(xlUp)).Select
For t = 1 To r
If Cells(t, d) <> "" Then
For t2 = t + 1 To r
If Cells(t, d) = Cells(t2, d) Then
Cells(t2, d) = ""
End If
Next
End If
Next

Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending

r = Cells(65500, d).End(xlUp).Row
For t = 2 To r
x = x & Cells(t, 3) & ", "
Next

Range("L1") = x
ActiveCell.Select
Sheets("Kunder").Select
End Sub

Faktisk er fejlen en anden ser jeg nu. Den holder sig stadig i C.

prøv denne

Sub SletDubletter() ' Slet i markeret kolonne
Sheets("Handelsoversigt").Select
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
d = 4
r = Cells(65500, d).End(xlUp).Row
Range(Cells(2, d), Cells(65500, d).End(xlUp)).Select
For t = 1 To r
If Cells(t, d) <> "" Then
For t2 = t + 1 To r
If Cells(t, d) = Cells(t2, d) Then
Cells(t2, d) = ""
End If
Next
End If
Next

Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending

r = Cells(65500, d).End(xlUp).Row
For t = 2 To r
x = x & Cells(t, 4) & ", "
Next

Range("L1") = x
ActiveCell.Select
Sheets("Kunder").Select
End Sub

Så var den der ... Igen, tusind tak for hjælpen :)