AW: Aus 'm Arciv von fcs
12.06.2006 18:46:51
fcs
Betrifft: AW: Doppelte Einträge suchen
Hallo Sebastian,
mit diesem Makro kann man Tabellen nach Mehrfacheinträgen in einer Spalte durchsuchen
Gruß
Franz
Sub DoppelteinSpalte()
' Sucht übere alle Blätter einer Mappe in einer Spalte doppelte Einträge und listet diese in einem separaten Blatt
Dim wb As Workbook, wks As Worksheet, wksdoppelte As Worksheet, Doppelt() As Boolean
Dim Finden As Range, Bereich As Range, Zeile As Long, wks2 As Worksheet, Doppeltes As Boolean
Dim J As Integer, K As Long, L As Integer, Zeile1 As Long, Spalte As Variant
Set wb = ActiveWorkbook
Spalte = 2 'Zu durchsuchende Spalte
' Tabellenblatt für Doppelte anlegen bzw. entleeren
Doppeltes = False
Zeile = 1 ' Startzeile für Einträge in Tabelle doppelte
For Each wks In wb.Sheets
If wks.Name = "Doppelte" Then
Set wksdoppelte = wks
Doppeltes = True
Exit For
End If
Next wks
If Doppeltes = True Then
With wksdoppelte
.Range(.Cells(2, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, "C")).ClearContents
End With
Else
Set wksdoppelte = wb.Sheets.Add
With wksdoppelte
.Name = "Doppelte"
.Cells(Zeile, 1).Value = "Tabelle"
.Cells(Zeile, 2).Value = "Wert Spalte C"
.Cells(Zeile, 3).Value = "Zeile"
End With
End If
ReDim Doppelt(1 To 65536, 1 To wb.Sheets.Count) 'Feld für Prüfeinträge von doppelten Zellinhalten
'Blätter nacheinander in der Spalte durchsuchen
For J = 1 To wb.Sheets.Count
Set wks = wb.Sheets(J)
If wks.Name <> wksdoppelte.Name Then
'Blatt durchsuchen
For K = 1 To wks.UsedRange.Row + wks.UsedRange.Rows.Count - 2
If Doppelt(K, J) = False Then 'Prüfung ob Zelle schon als doppelt markiert
Suchen = wks.Cells(K, Spalte).Value
Set Bereich = wks.Range(wks.Cells(K + 1, Spalte), wks.Cells(wks.UsedRange.Row + wks.UsedRange.Rows.Count - 1, Spalte))
Set Finden = Bereich.Find(what:=Suchen, LookIn:=xlValues, Lookat:=xlWhole)
Doppeltes = True
If Not Finden Is Nothing Then
Zeile1 = Finden.Row
With wksdoppelte
'Infos zu Zelle mit gesuchtem Wert eintragen
Zeile = Zeile + 1
.Cells(Zeile, 1) = wks.Name
.Cells(Zeile, 2) = Suchen
.Cells(Zeile, 3) = wks.Cells(K, (Spalte)).Row
Doppelt(K, J) = True
Doppeltes = False
'infos zu Doppelte eintragen und weitere doppelte suchen
Do
Doppelt(Finden.Row, J) = True
Zeile = Zeile + 1
.Cells(Zeile, 1) = wks.Name
.Cells(Zeile, 2) = Suchen
.Cells(Zeile, 3) = Finden.Row
Set Finden = Bereich.FindNext
Loop Until (Finden.Row = Zeile1 Or Finden Is Nothing)
End With
End If
End If
'restliche Blätter durchsuchen
For L = J + 1 To wb.Sheets.Count
Set wks2 = wb.Sheets(L)
If wks2.Name <> wksdoppelte.Name Then
Set Bereich = wks2.Range(wks2.Cells(1, Spalte), wks2.Cells(wks2.UsedRange.Row + wks2.UsedRange.Rows.Count - 1, Spalte))
Set Finden = Bereich.Find(what:=Suchen, LookIn:=xlValues, Lookat:=xlWhole)
If Not Finden Is Nothing Then
Zeile1 = Finden.Row
With wksdoppelte
If Doppeltes = True Then
Zeile = Zeile + 1
'Infos zu Zelle mit gesuchtem Wert eintragen
.Cells(Zeile, 1) = wks.Name
.Cells(Zeile, 2) = Suchen
.Cells(Zeile, 3) = wks.Cells(K, (Spalte)).Row
Doppelt(K, J) = True
Doppeltes = False
End If
'infos zu Doppelte eintragen und weitere doppelte suchen
Do
Doppelt(Finden.Row, L) = True
Zeile = Zeile + 1
.Cells(Zeile, 1) = wks2.Name
.Cells(Zeile, 2) = Suchen
.Cells(Zeile, 3) = Finden.Row
Set Finden = Bereich.FindNext
Loop Until Finden.Row = Zeile1 Or Finden Is Nothing
End With
End If
End If
Next L
Next K
End If
Next J
ReDim Doppelte(0)
MsgBox "Suchvorgang ist abgeschlossen"
End Sub
Grüße
Gerd