Option Explicit
Sub DoppelteEintaegeInEinerSpalteFinden()
Dim wb As Workbook
Dim ws As Worksheet, l_rows As Long, l_col As Long
Dim ws2 As Worksheet, l_rows2 As Long
Dim l_ZeileErsteDoppelte As Long, x As Long, z As Long, y As Long, s_Spalte As String
Dim s_Meldung As String, s_Doppelte As String, s_Adr As String, s_Such As String
Dim f_doppelt() As Long, f_doppelt_cnt As Long, ret As Integer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
If Selection.Columns.Count > 1 Then
MsgBox ( _
Es sind & Selection.Columns.Count & Spalten selektiert. & vbLf & _
Bitte slektieren Sie nur eine Spalte / Zelle.)
Else
->letzte zeile bestimmen
l_col = Selection.Column
l_rows = ws.Cells(ws.Rows.Count, l_col).End(xlUp).Row
->Spalte in A-Form
s_Spalte = ws.Columns(l_col).Address(rowabsolute:=False, columnabsolute:=False)
s_Spalte = Left(s_Spalte, Len(s_Spalte) \ 2)
->Bildschirm-Update abschalten
Application.ScreenUpdating = False
->Temporäres Blatt erzeugen
Set ws2 = wb.Worksheets.Add
->relevante Spalte auf temporäres Blatt kopieren
ws.Range(ws.Cells(1, l_col), ws.Cells(l_rows, l_col)).Copy Destination:=ws2.Range(Cells(1, 1), Cells(1, 1))
ws2.Activate
->Zeilenummern in Spalte 2, dann nach Spalte 1 sortieren
ws2.Cells(1, 2).Value = 1
If l_rows > 1 Then
ws2.Cells(1, 2).AutoFill Destination:=ws2.Range(Cells(1, 2), Cells(l_rows, 2)), Type:=xlFillSeries
ws2.Range(ws2.Cells(1, 1), ws2.Cells(l_rows, 2)).Sort _
Key1:=ws2.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
End If
->releavnte Zeilenanzahl auf temp. Blatt/ Spalte1
l_rows2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
->für alle Zellen der Spalte
l_ZeileErsteDoppelte = 0
For z = 1 To l_rows2 - 1
With ws2.Cells(z, 1)
->Zell-Inhalt mit Nachfolger vergleichen
If .Value = .Offset(1, 0).Value Then
->bei Gleichheit: ursprüngliche Zeilennummer aus Spalte 2
l_ZeileErsteDoppelte = .Offset(0, 1).Value
-> bei erstem Fund abbrechen
GoTo Resultat
End If
End With
Next
Resultat:
->dem resultat entsprechende Meldung aufbereiten
If l_ZeileErsteDoppelte = 0 Then
MsgBox (Es ist kein Begriff in Spalte & s_Spalte & mehrfach vorhanden.)
Else
->alle Fundorte für den doppeltgefundenen Eintrag suchen und merken
ReDim f_doppelt(1 To 1): f_doppelt_cnt = 0
With ws.Cells(l_ZeileErsteDoppelte, l_col)
For z = 1 To l_rows
If z <> l_ZeileErsteDoppelte Then
If .Value = ws.Cells(z, l_col).Value Then
f_doppelt_cnt = f_doppelt_cnt + 1
ReDim Preserve f_doppelt(1 To f_doppelt_cnt)
f_doppelt(f_doppelt_cnt) = z
End If
End If
Next
->Meldungstext zur ersten Fundstelle aufbereiten
s_Meldung = _
Erster mehrfach vorkommender Eintrag in & _
.Address(rowabsolute:=False, columnabsolute:=False) & : & vbLf
If Len(.Value) > 100 Then
s_Meldung = s_Meldung & Left(.Value, 100) & ....
Else
s_Meldung = s_Meldung & .Value
End If
End With
->Meldungstext der doppelten aufbereiten
s_Doppelte = doppelt in :
For x = 1 To f_doppelt_cnt
If x = 10 Then
s_Doppelte = s_Doppelte & , ....
Exit For
Else
s_Adr = ws.Cells(f_doppelt(x), l_col).Address(rowabsolute:=False, columnabsolute:=False)
If x <> 1 Then s_Doppelte = s_Doppelte & ,
s_Doppelte = s_Doppelte & s_Adr
End If
Next
ws.Activate
->erste Fundstelle selektieren
ws.Cells(l_ZeileErsteDoppelte, l_col).Select
->Meldung ausgeben
ret = MsgBox(s_Meldung & vbLf & vbLf & s_Doppelte & vbLf & vbLf & _
Soll der nächste doppelte Eintrag selektiert werden ?, _
vbYesNo + vbDefaultButton1 + vbQuestion)
If ret = vbYes Then
->Wenn erster doppelter Fundort selektiert werden soll, selektieren
ws.Cells(f_doppelt(1), l_col).Select
End If
End If
End If
Aufraeumen:
Application.DisplayAlerts = False
ws2.Delete->temp.Blatt löschen
Application.DisplayAlerts = False
->Bildschirmupdate anschalten
Application.ScreenUpdating = False
->Objekt-Variablen freigeben
Set ws2 = Nothing:Set ws = Nothing: Set wb = Nothing
End Sub
