Attribute VB_Name = "Modul1"
Option Explicit

'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ globale Variablen
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Private aktion_value As String
Private selection_only_value As Boolean
Private first_color_value As Long
Private mark_color_value As Long
Private treffer(1) As New Collection
Private dups_entfernt As Boolean

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ teste_auf_gleich ruft den Zeilenvergleich auf
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ wer die Parameter nicht über eine Inputbox
'+ setzen will, der aktiviert die Zeile:
'+ set_parameter arg1, arg2, arg3, arg4
'+
'+ Wertebereich(e):
'+ arg1= [löschen|markieren|auflisten|kopieren]
'+     löschen:   löscht alle Doppelten
'+     markieren: markiert die Doppelten im
'+                Farbwert <arg4>
'+     auflisten: legt Original-Doppel-PAARE
'+                in einer Collection ab
'+     kopieren:  Funktion FEHLT noch!
'+
'+ arg2= [True|False]
'+     true: es werden nur die selektierten
'+           Spalten auf Gleichheit überprüft
'+     false:es werden ALLE Spalten (1..256)
'+           auf Gleichheit überprüft
'+     Zeilenzahl wird über UsedRange ermittelt
'+
'+ arg3= Farbwert für die Originale
'+       default=vbYellow bzw. 65535
'+
'+ arg4= Farbwert für die Doppelten
'+       default=32225 helles rot
'+++++++++++++++++++++++++++++++++++++++++++++++++

Sub teste_auf_gleich()
Dim sr As Long
Dim fr As Long
Dim ergebnis As Boolean

   With ActiveSheet
   Set treffer(0) = Nothing
   Set treffer(1) = Nothing
   dups_entfernt = False
   If .UsedRange.Rows.Count < 2 Then Exit Sub
   Application.ScreenUpdating = False
   'second_row
   For sr = .UsedRange.Rows.Count To 2 Step -1
     'first_row
     For fr = 1 To sr - 1
        '==============>
        'set_parameter "auflisten", True, vbYellow, 32225
        '==============>
        ergebnis = zeilenvergleich(fr, sr)
        If ergebnis Then GoTo weiter_in_sr
        Next fr
weiter_in_sr:
   Next sr
   End With
   Application.ScreenUpdating = True
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ zeilenvergleich vergleicht einfach nur 2 übergebene Zeilen
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Rückgabewert der Funktion:
'+    True=  Zeilen(bereiche) sind gleich
'+    False= Zeilen(bereiche) sind NICHT gleich
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Function zeilenvergleich(ByVal z1 As Long, _
                                ByVal z2 As Long) As Boolean

Dim sc As Long
Dim ec As Long
Dim i As Long

If aktion_value = "" Then default_parameter

Select Case LCase(aktion_value)
   Case "löschen":
   Case "markieren":
   Case "auflisten":
   Case "kopieren":
   Case Else: aktion_value = "löschen"
   End Select

If selection_only_value Then
   sc = Selection.Column
   ec = Selection.Column + Selection.Columns.Count - 1
   Else
   sc = 1
   ec = 256
   End If
   
   zeilenvergleich = True
   
   For i = sc To ec
      If Cells(z1, i) <> Cells(z2, i) Then
         zeilenvergleich = False
         Exit Function
         End If
         Next i
         
   Select Case aktion_value
      Case "löschen":
           Range(Cells(z2, sc), Cells(z2, ec)).Delete shift:=xlUp
      Case "markieren":
           Range(Cells(z2, sc), Cells(z2, ec)).Interior.Color = mark_color_value
      Case "auflisten":
           treffer(0).Add Range(Cells(z1, sc), Cells(z1, ec)).Address
           treffer(1).Add Range(Cells(z2, sc), Cells(z2, ec)).Address
      Case "kopieren": 'noch nicht implementiert!
      Case Else:
           MsgBox "Fehler in Variable [aktion]"
      End Select
End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ setze Defaultparameter
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub default_parameter()
  aktion_value = "löschen"
  selection_only_value = True
  first_color_value = vbYellow
  mark_color_value = 32225 'helles rot
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ setze Parameter in einer Inputbox
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Reihenfolge im String:
'+       aktion,selection_only,OriginalFarbe,DoppelFarbe
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub set_parameter_ip()
'wie set_parameter, aber mit Inputbox
On Error GoTo err_hndl
Dim parameterstring As String
Dim i As Integer
If aktion_value = "" Then default_parameter
parameterstring = CStr(aktion_value) & "," & _
                 CStr(selection_only_value) & "," & _
                 CStr(first_color_value) & "," & _
                 CStr(mark_color_value)
i = 0
parameterstring = InputBox("gesetzte Werte", "Parameter für den Zeilenvergleich", parameterstring)
If parameterstring = "" Then GoTo err_hndl
i = InStr(1, parameterstring, ",")
If i = 0 Then
    aktion_value = parameterstring
    parameterstring = ""
    Else
    aktion_value = Left(parameterstring, i - 1)
    parameterstring = Right(parameterstring, Len(parameterstring) - i)
    End If
i = InStr(1, parameterstring, ",")
If i = 0 Then
    selection_only_value = CBool(parameterstring)
    parameterstring = ""
    Else
    selection_only_value = CBool(Left(parameterstring, i - 1))
    parameterstring = Right(parameterstring, Len(parameterstring) - i)
    End If
i = InStr(1, parameterstring, ",")
If i = 0 Then
    first_color_value = CLng(parameterstring)
    parameterstring = ""
    Else
    first_color_value = CLng(Left(parameterstring, i - 1))
    parameterstring = Right(parameterstring, Len(parameterstring) - i)
    End If
i = InStr(1, parameterstring, ",")
If i = 0 Then
    mark_color_value = CLng(parameterstring)
    parameterstring = ""
    Else
    mark_color_value = CLng(Left(parameterstring, i - 1))
    parameterstring = Right(parameterstring, Len(parameterstring) - i)
    End If
    Exit Sub
err_hndl:
parameterstring = CStr(aktion_value) & "," & _
                 CStr(selection_only_value) & "," & _
                 CStr(first_color_value) & "," & _
                 CStr(mark_color_value)
MsgBox parameterstring, , "Fehler oder Abbruch! Parameter sind:"
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ setze Parameter für den Aufruf in VBA Code
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Reihenfolge der Parameter:
'+       aktion,selection_only,OriginalFarbe,DoppelFarbe
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub set_parameter(a As String, b As Boolean, _
                         c1 As Long, c2 As Long)
On Error Resume Next
  default_parameter
  aktion_value = a
  selection_only_value = b
  first_color_value = c1
  mark_color_value = c2
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ zeigt Treffer einzeln
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ WENN über Aktion "auflisten" eine
'+ TrefferCollection angelegt wurde, dann kann
'+ die Auflistung hiermit in Einzelschritten
'+ durchlaufen werden - wer die For-Schleife
'+ evtl auch abbrechen will muß die Msgbox
'+ ändern und die Rückgabe verarbeiten
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub zeige_treffer_einzeln()
Dim r As Variant
If treffer(0).Count < 1 Then Exit Sub
For r = 1 To treffer(0).Count
  Range(treffer(0)(r)).Interior.Color = first_color_value
  Range(treffer(1)(r)).Interior.Color = mark_color_value
  MsgBox "weiter"
  Range(treffer(0)(r)).Interior.ColorIndex = xlNone
  Range(treffer(1)(r)).Interior.ColorIndex = xlNone
  Next r
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ zeigt alle Treffer
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ WENN über Aktion "auflisten" eine
'+ TrefferCollection angelegt wurde, dann kann
'+ die Auflistung hiermit komplett zweifarbig
'+ angezeigt werden
'+ NICHT markierte Zeilen haben KEINE Doppelgänger
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub zeige_alle_treffer()
Dim r As Variant
If treffer(0).Count < 1 Then Exit Sub
For r = 1 To treffer(0).Count
  Range(treffer(0)(r)).Interior.Color = first_color_value
  Range(treffer(1)(r)).Interior.Color = mark_color_value
  Next r
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ entfernt nur die Farbmarkierungen
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ "zeige_alle_treffer" setzt Farbmarken,
'+ die hiermit wieder gelöscht werden können
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub entferne_alle_trefferMarkierungen()
Dim r As Variant
If treffer(0).Count < 1 Then Exit Sub
For r = 1 To treffer(0).Count
  Range(treffer(0)(r)).Interior.ColorIndex = xlNone
  Range(treffer(1)(r)).Interior.ColorIndex = xlNone
  Next r
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ entfernt die doppelten Zeilen oder Zellbereiche
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ hiermit werden entweder die doppelten Zeilen
'+ oder nur die doppelten Zellbereiche GELÖSCHT
'+ (je nachdem wie selection_only_value bei
'+  der Erfassung der Collection eingestellt war)
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub entferne_alle_doppelten()
Dim r As Variant
If treffer(0).Count < 1 Or dups_entfernt Then Exit Sub
For r = 1 To treffer(1).Count
  Range(treffer(1)(r)).Delete shift:=xlUp
  Next r
  dups_entfernt = True
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ >>>>>> 1.Erweiterung !
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ blendet alle Duplikatzeilen aus
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub verstecke_alle_doppelten()
Dim r As Variant
If treffer(1).Count < 1 Or dups_entfernt Then Exit Sub
For r = 1 To treffer(1).Count
  Range(treffer(1)(r)).EntireRow.Hidden = True
  Next r
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ blendet alle Duplikatzeilen wieder ein
'+ wenn sie nicht zuvor gelöscht wurden!
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub zeige_alle_doppelten()
Dim r As Variant
If treffer(1).Count < 1 Or dups_entfernt Then Exit Sub
For r = 1 To treffer(1).Count
  Range(treffer(1)(r)).EntireRow.Hidden = False
  Next r
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ löscht bei Duplikaten IMMER die gesamte Zeile
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub lösche_GANZE_duplikatzeilen()
Dim r As Variant
If treffer(1).Count < 1 Or dups_entfernt Then Exit Sub
For r = 1 To treffer(1).Count
  Range(treffer(1)(r)).EntireRow.Delete shift:=xlUp
  Next r
  dups_entfernt = True
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ ANWENDUNGSBEISPIEL_1:
'+ sucht Duplikate in Spalte A
'+ zeigt diese an, versteckt sie und löscht
'+ zum Schluß bei Duplikaten IMMER die gesamte Zeile
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub ANWENDUNGSBEISPIEL_1()
   set_parameter "auflisten", True, vbYellow, 32225
   Columns(1).Select
   teste_auf_gleich
   zeige_alle_treffer
   MsgBox "", vbOKOnly, "verstecke Duplikate!"
   verstecke_alle_doppelten
   MsgBox "", vbOKOnly, "zeige Duplikate wider an!"
   zeige_alle_doppelten
   MsgBox "", vbOKOnly, "lösche GANZE Duplikatzeilen!"
   lösche_GANZE_duplikatzeilen
   entferne_alle_trefferMarkierungen
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ ANWENDUNGSBEISPIEL_2:
'+ sucht Duplikate in Spalte A
'+ versteckt sie und kopiert alle sichtbaren
'+ Zeilen ins 2.Arbeitsblatt
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub ANWENDUNGSBEISPIEL_2()
   Dim i As Integer
   Dim zaehler As Integer
   set_parameter "auflisten", True, vbYellow, 32225
   Application.ScreenUpdating = False
   With ActiveSheet
      Columns(1).Select
      teste_auf_gleich
      verstecke_alle_doppelten
      If .UsedRange.Rows.Count < 1 Then Exit Sub
      zaehler = 0
      For i = 1 To .UsedRange.Rows.Count
         If Rows(i).Hidden = False Then
            Rows(i).Copy
            zaehler = zaehler + 1
            Worksheets(2).Rows(zaehler).PasteSpecial xlPasteAll
            End If
         Next i
      zeige_alle_doppelten
      End With
      Application.ScreenUpdating = True
 End Sub