Supportnet / Forum / Tabellenkalkulation
Doppelte Einträge entfernen
Frage
Hallo zusammen,
ich habe folgendes Problem, ich habe eine Excel-Liste mit ca. 20000 Datensätzen, die aber leider doppelt vorhanden sind. Ich möchte nun mit einem Makro die doppelten Zellen entfernen. Wer hat eine Idee?
Vielen Dank schon mal im vorraus.
Helmut
PS: Ist wahrscheinlich ganz einfach, aber meine Gehirnzellen wollen heute nicht so :-)
Antwort 1 von martl
Hallo Helmut,
mal aus der Hüfte geschossen:
Sub löschen()
Dim i As Integer
For i = 2 To 20000
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Rows(i).Select
Selection.Delete Shift:=xlUp
End If
Next i
End Sub
der Code bezieht sich auf die Spalte A, die Daten müssen aber sortiert sein.
Grüßle
martl
mal aus der Hüfte geschossen:
Sub löschen()
Dim i As Integer
For i = 2 To 20000
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Rows(i).Select
Selection.Delete Shift:=xlUp
End If
Next i
End Sub
der Code bezieht sich auf die Spalte A, die Daten müssen aber sortiert sein.
Grüßle
martl
Antwort 2 von TJd
Hallo Hellehbk,
probiere doch mal das folgende Makro:
Das ist nicht auf meinem Mist gewachsen sondern von Nighty, den ich an dieser Stelle auch mal grüssen möchte.
Das Teil hat mir schon viele gute Dienste geleistet.
Gutes gelingen und einen schönen Tag wünscht
TJ
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
a = LastCell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Range("A" & t%) <> "" And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
Else
If Range("A" & t1%) = Range("A" & t%) And Range("A" & t%) <> "" And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichnung " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
probiere doch mal das folgende Makro:
Das ist nicht auf meinem Mist gewachsen sondern von Nighty, den ich an dieser Stelle auch mal grüssen möchte.
Das Teil hat mir schon viele gute Dienste geleistet.
Gutes gelingen und einen schönen Tag wünscht
TJ
Sub Makro1()
Set LastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = LastCell.Row
a = LastCell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
altb = LastCell.Column
b = LastCell.Column
Do While Application.CountA(Columns(b)) = 0 And b <> 1
b = b - 1
Loop
altb = b
lzeile = alta
lspalte = altb
For t% = 1 To lzeile
For t1% = t% + 1 To lzeile
If Range("A" & t1%) = Range("A" & t%) And Range("A" & t%) <> "" And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) <= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t1%
GoSub msgbox
If Beenden = vbYes Then
Rows(t1% & ":" & t1%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
Else
If Range("A" & t1%) = Range("A" & t%) And Range("A" & t%) <> "" And Val(Mid$(Range("C" & t1%), 7, 4) & "1" & Mid$(Range("C" & t1%), 4, 2) & "1" & Mid$(Range("C" & t1%), 1, 2)) >= Val(Mid$(Range("C" & t%), 7, 4) & "1" & Mid$(Range("C" & t%), 4, 2) & "1" & Mid$(Range("C" & t%), 1, 2)) Then
t2% = t%
GoSub msgbox
If Beenden = vbYes Then
Rows(t% & ":" & t%).Select
Selection.Delete Shift:=xlUp
t1% = t1% - 1
lzeile = lzeile - 1
End If
End If
End If
Next t1%
Next t%
Range("A1").Select
End
msgbox:
Beenden = _
msgbox( _
"Eine doppelte Eintragung wurde gefunden." & Chr(13) & _
"Möchten Sie Sie jetzt löschen ?" & Chr(13) & Chr(13) & _
"Artikelnummer " & Range("a" & t2%) & Chr(13) & _
"Bezeichnung " & Range("b" & t2%) & Chr(13) & _
"Datum " & Range("c" & t2%) & Chr(13) & _
Chr(13) & _
Chr(13), vbYesNo + vbQuestion)
Return
End Sub
Antwort 3 von want2cu
Hallo Hellehbk,
du hast zwar nach einem Makro gefragt, aber als Ergänzung noch ein Tipp OHNE Makro:
Daten -Filter-Spezialfilter-keine Duplikate
CU
want2cu
du hast zwar nach einem Makro gefragt, aber als Ergänzung noch ein Tipp OHNE Makro:
Daten -Filter-Spezialfilter-keine Duplikate
CU
want2cu