AW: Du musst schon bissel was mitteilen,...
07.08.2014 15:45:59
Urs
hallo Matze.
hier das Makro
Sub Dubletten()
' Durchsucht eine Spalte in allen Tabellen der Mappe nach Mehrfacheinträgen
Spalte = 9 'Spalte die durchsucht werden soll
SpalteM = 8 'Spalte für Markierung der Mehrfacheinträge ("M" wird eingetragen)
Zeile1 = 6 'Zeile in der in jeder Tabelle mit dem Vergleich begonnen werden soll
Farbe = 15 ' Colorindex für Füllfarbe bei Mehrfacheinträgen, 3 = Rot
With ActiveWorkbook
For i = 1 To .Sheets.Count
For ZeileI = Zeile1 To .Sheets(i).Cells(.Sheets(i).Rows.Count, Spalte).End(xlUp).Row
'Bereits markierte Zeile überspringen
If .Sheets(i).Cells(ZeileI, SpalteM) = "M" Then GoTo NextI
Wert = .Sheets(i).Cells(ZeileI, Spalte)
'Vergleich mit restlichen Zellen
For j = i To .Sheets.Count
'Startzeile für Vergleichstabelle setzen
If i = j Then
' steht Wert in der letzten Zeile des Blattes i dann wird im nächten Blatt weitergesucht
If ZeileI = .Sheets(i).Cells(.Sheets(i).Rows.Count, Spalte).End(xlUp).Row Then Exit For
ZeileJStart = ZeileI + 1
Else
ZeileJStart = Zeile1
End If
For ZeileJ = ZeileJStart To .Sheets(j).Cells(.Sheets(j).Rows.Count, Spalte).End(xlUp).Row
'Prüfung ob Zeile bereits markiert als Mehrfacheintrag
If .Sheets(j).Cells(ZeileJ, SpalteM) = "M" Then GoTo NextJ
'Wertevergleich
If Wert = .Sheets(j).Cells(ZeileJ, Spalte) Then
.Sheets(j).Cells(ZeileJ, SpalteM) = "M"
.Sheets(j).Rows(ZeileJ).Interior.ColorIndex = Farbe
Mehrfach = True
End If
NextJ:
Next ZeileJ
Next j
'1. Zeile mit Wert auch markieren
If Mehrfach = True Then
.Sheets(i).Cells(ZeileI, SpalteM) = "M"
.Sheets(i).Rows(ZeileI).Interior.ColorIndex = Farbe
Mehrfach = False
End If
NextI:
Next ZeileI
Next i
End With
' Markierungen in SpalteM entfernen?
If MsgBox("Markierung 'M' in Spalte " & SpalteM & " entfernen?", vbYesNo + vbQuestion, _
"Mehrfacheinträge suchen") = vbYes Then
ActiveWorkbook.Sheets.Select
Columns(SpalteM).Select
Selection.ClearContents
Range("A1").Select
Sheets(1).Select
End If
End Sub
