Fjern dublet

Denne kode markere dubletere i kolonne A



Sub test_mark_dups()
  'Kontroller varenavne for dubletter, markeres gule
  Dim Rng1 As Range
  Dim rstart1 As Range

    MsgBox ("Kontroller varenavne for dubletter, markeres gule")
    Set rstart1 = ActiveSheet.Range("A1")
    Set Rng1 = Range(rstart1.Offset(0, 0), Cells(65535, rstart1.Column).End(xlUp))
       
    Rng1.Interior.ColorIndex = 0
    MarkDuplicates Rng1, vbYellow
   
End Sub


Private Sub MarkDuplicates(rlist As Range, lColor As Long)
Dim Cell As Range
Dim Uniqs As Object 'New Dictionary
Set Uniqs = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Cell In rlist
      Uniqs.Add UCase(Cell.Value), CStr(UCase(Cell.Value))
      If Err.Number <> 0 And Cell.Value <> Empty Then Cell.Interior.Color = lColor
      Err.Clear
  Next Cell
  Application.ScreenUpdating = True

Tak for hjælpen - undskyld det sene svar.

Smid et svar og få dine point :-)

bedre sent end aldrig :o)