undersøge dubletter

http://www.eksperten.dk/spm/Programmer/Regneark/Excel/?sort=&order=DESC&status_3=on&spm_creator=&spm_part=&spm_answer=&find=dubletter&engine=exp&excerpt_on=1

ja har prøvet at få =IF(COUNTIF(A$1:A1;A1)>1;"Dublet";"") til at fungere men det gælder kun ved en kolenne, der er flere kolener.

Hvordan tager jeg flere kolener med?? kan ik rigtig få det til at fungere, da der er sammehæng mellem kolenerne

Husk at have en backup inden du kører makro
Koden fjerner evt. dubletter

Sub Dubletter() ' i område
Dim x, r As Double, c As Double, t, t2
Dim v(1000)
'x = Range("A1:J15")
x = Application.InputBox(prompt:="Marker område dubletter skal fjernes fra: ", Type:=8)
For c = 1 To UBound(x, 2)
For r = 1 To UBound(x, 1)
If x(r, c) <> "" Then t = t + 1: v(t) = x(r, c)
Next
Next

For t = 1 To UBound(v)
If v(t) <> "" Then
For t2 = t + 1 To UBound(v)
If v(t) = v(t2) Then
v(t2) = Empty
End If
Next
End If
Next
Application.InputBox(prompt:="Marker kolonne hvor ny list skal skrives: ", Type:=8).Select
For t = 1 To UBound(v)
Cells(t, ActiveCell.Column) = v(t)
Next
On Error Resume Next
Selection.Columns.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlUp
Range(ActiveCell, ActiveCell.End(xlDown)).Select
If MsgBox("Skal liste sorteres", vbYesNo, "Fjern dubletter") = vbYes Then
Selection.Sort Key1:=Range(ActiveCell.Address), Order1:=xlAscending
End If
ActiveCell.Select
End Sub

en anden metode : slette evt. dubletter i det markerede område

Sub SletDubletter() ' Slet i markeret område

x = Application.InputBox(prompt:="Marker område dubletter skal fjernes fra: ", Type:=8).Address

For Each c In Range(x)
For Each c2 In Range(x)
If c.Value = c2.Value And c.Address <> c2.Address Then Range(c2.Address) = ""
Next
Next

End Sub

tak skal du have:D

Hvis excelent's svar har afjulpet dit problem, må du bede om et svar. Uden det kan du ikke give point.

jo du excelent skal have point , svar plz

Rem Data er sorteret iflg. For- Efter-navn & By

Dim T_eNavn, T_fNavn, T_By
Dim t_række
Public Sub FindDubletter()
Dim dub As Boolean
    For ræk = 2 To 65000
        If ræk = 2 Then
            T_eNavn = Cells(ræk, 1)
            T_fNavn = Cells(ræk, 2)
            T_By = Cells(ræk, 4)
            t_række = 2
        Else
Rem Er sidste række behandlet nået
            If Cells(ræk, 1) = "" Then
                Exit For
            End If
           
            dub = testDublet(ræk)
            If dub = True Then
                markerDub ræk, t_række
            End If
           
            T_eNavn = Cells(ræk, 1)
            T_fNavn = Cells(ræk, 2)
            T_By = Cells(ræk, 4)
            t_række = ræk
        End If
    Next ræk
   
    MsgBox ("Gennemløb afsluttet")
End Sub
Private Function testDublet(ræk) As Boolean
Dim A_eNavn, A_fNavn, A_By, ens As Boolean
    testDublet = False
Rem aktuelle data
    A_eNavn = Cells(ræk, 1)
    A_fNavn = Cells(ræk, 2)
    A_By = Cells(ræk, 4)
   
Rem Samme efteravn
    If A_eNavn = T_eNavn Then
        If A_fNavn = T_fNavn Then
            If A_By = T_By Then
                testDublet = True
                Exit Function
            End If
        End If
    End If
   
    testDublet = False
End Function
Private Sub markerDub(ræk, t_række)
    Cells(t_række, 1).Interior.ColorIndex = 4
    Cells(ræk, 1).Interior.ColorIndex = 6

Rem sæt "Dub" i kolonne N - for at kunne anvende filtrering
    Cells(t_række, 14) = "DUB"
    Cells(ræk, 14) = "DUB"
End Sub

ok velbekom