falsches Goto
13.09.2011 13:49:15
Erich
Hi Didi,
solchen Code - ohne "Option Explicit" und Variablendeklarationen, dafür mit "... Goto xyz"-Anweisungen,
mag ich wirklich ganz besonders :-(
So sollte es gehen (immer noch ohne Option Explicit und nicht wirklich getestet,
aber mit übersichtlicheren Einrückungen):
' Option Explicit ' Warum kein Option Explicit ?
Sub Dubletten() ' Durchsucht eine Spalte in Tabellen der Mappe nach Mehrfacheinträgen
Spalte = 2 'Spalte die durchsucht werden soll
SpalteM = 10 'Spalte für Markierung der Mehrfacheinträge ("M" wird eingetragen)
Zeile1 = 19 'Zeile in der in jeder Tabelle mit dem Vergleich begonnen werden soll
Farbe = 3 '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
wert = .Sheets(i).Cells(ZeileI, Spalte)
For j = i To .Sheets.Count 'Vergleich mit restlichen Zellen
'Startzeile für Vergleichstabelle setzen
If i = j Then
' steht Wert in letzter Zeile des Blattes i, wird ab nächstem Blatt gesucht
If ZeileI = _
.Sheets(i).Cells(.Sheets(i).Rows.Count, Spalte).End(xlUp).Row Then
ZeileJStart = 9 ^ 99
Else
ZeileJStart = ZeileI + 1
End If
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
If wert = .Sheets(j).Cells(ZeileJ, Spalte) Then 'Wertevergleich
.Sheets(j).Cells(ZeileJ, SpalteM) = "M"
.Sheets(j).Rows(ZeileJ).Interior.ColorIndex = Farbe
Mehrfach = True
End If
End If
Next ZeileJ
Next j
If Mehrfach = True Then
.Sheets(i).Cells(ZeileI, SpalteM) = "M" '1. Zeile mit Wert auch markieren
.Sheets(i).Rows(ZeileI).Interior.ColorIndex = Farbe
Mehrfach = False
End If
End If
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
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort