Fjerne dubletter i A kollonne

Sub SletDubletter()
Sheets("Ark1").Range("A1:A2000").Copy Sheets("Ark2").Range("A1")
Sheets("Ark2").Select
Dim c, r, t, t2
c = 1
r = Cells(65500, c).End(xlUp).Row
Range(Cells(1, 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
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlUp
If MsgBox("Skal liste sorteres", vbYesNo, "Fjern dubletter") = vbYes Then
Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending
End If
ActiveCell.Select
End Sub

koden kopierer Ark1!A1:A2000 til Ark2!A1

Hej,

Tak for det, men det virker ikke rigtigt. Jeg får en fejlkode 400. Den laver et eller andet og kopierer også til et nytt ark men den tager alle data med. Feks hvis jeg har 2 rækker med tallet 47 skal den slette/flytte den over til et nyt ark. Det gør den ikke nu.

Feks.

1. A1
2. A2
3. A3
4. A1
5. A2
6. A6
Her skal räkkerne 4 & 5 slettes da de findes flere gange.

hvad hedder dir ark med kundenr.
og hvilket ark skal de kopieres til

Arket hedder sheet3 og det skal kopieres til sheet1 men det har jeg taget höjde for og ändret i din kode.

Det var mystisk, det er ellers en ofte anvendt kode
prøv lige at paste koden her som den er nu

Jepper! Her er den :-)

Sub SletDubletter()

Sheets("Sheet3").Range("A2:O65500").Copy Sheets("Sheet1").Range("A1")
Sheets("Sheet1").Select
Dim c, r, t, t2
c = 1
r = Cells(65500, c).End(xlUp).Row
Range(Cells(1, 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
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlUp
ActiveCell.Select
End Sub

prøv lige denne

Sub SletDubletter()
Dim c, r, t, t2
Sheets("Sheet3").Range("A2:O65500").Copy Sheets("Sheet1").Range("A1")
Sheets("Sheet1").Select
c = 1
r = Cells(65500, c).End(xlUp).Row
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Range("A" & t2 & ":O" & t2) = ""
End If
Next
End If
Next
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlUp
ActiveCell.Select
End Sub

Det virker fint nu.....mange tak for al hjälp :)

Svar for points :)

ok velbekom

Har lige et tilæg som jeg håber at du kan svare på :-)
Jeg har data i flere kolonner end kun A og det viser sig at den "rykker" data et skridt op og derfor bliver min data forskudt. Kan det lade sig gøre at den flytter/sletter hele rækker/rows istedet? :-)

Ex. på orginaldata
Række 1, tekst 1
Række 2, tekst 2
Række 3, tekst 3


Ex. efter makro Hvis række 2 opfylder kriterier for makro.
Række 1, tekst 1
Række 3, tekst 2
        tekst 3

Jeg smider gerne lidt flere points :-)

Udskift hele koden :

Sub SletDubletter()
Dim c, r, t, t2, rk
rk = Sheets("Sheet3").Cells(65500, 1).End(xlUp).Row
Sheets("Sheet3").Range("A2:O" & rk).Copy Sheets("Sheet1").Range("A1")
Sheets("Sheet1").Select
c = 1
r = Cells(65500, c).End(xlUp).Row
For t = 1 To r
If Cells(t, c) <> "" Then
For t2 = t + 1 To r
If Cells(t, c) = Cells(t2, c) Then
Range("A" & t2) = ""
End If
Next
End If
Next
On Error Resume Next
Range("A1:A" & rk).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveCell.Select
End Sub

Mange tak :-)