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

DA FOLGENDER CODE NOCH GANZ SPEZIELLE EIGENHEITEN HAT
GIBT ES IM EXCEL-VERZEICHNIS UNTER

http://www.rendar.de/excel/FINDE_GLEICHE2.BAS

EINE NEUE ALLGEMEINE VERSION, WELCHE ZEILEN (bzw. ZELLBEREICHE
VON ZEILEN) VERGLEICHT UND BEI GLEICHHEIT EINE ZEILE (bzw. DEN
ZELLBEREICH) LÖSCHT ODER MARKIERT - BEIM LÖSCHEN WERDEN ZELLEN
MIT "xlUp" NACH OBEN VERSCHOBEN!

hier folgt nun die ALTE Version, die im Gegensatz zur Neuen die
Prüfung auf Gleichheit mittels REKURSION erledigt ... darum habe
ich diesen Code noch nicht entfernt ... evtl. extern brauchbar
sind davon imho eigentlich nur die SUB's "ist_gleich" bzw. 
"ist_gleich_to_max_spalte"


Global gleich As Boolean

'gibt es bei Abbruch=true in zwei Zeilen zufällig in der gleichen
'Spalte eine LEERE Zelle, wird der Rest der Zeile nicht mehr
'auf Gleichheit geprüft, sondern die zweite Zeile sofort
'GELÖSCHT. Dies wird mit Abbruch=false verhindert, dann wird
'immer bis zur Spalte ms (=12 gesetzt) auf Zellgleichheit
'geprüft.

'Immer nach der Prüfung auf Gleichheit werden fehlende Zelleinträge
'gesucht und variabel ersetzt. Der jeweilige Eintrag wird in einem
'Select Case Block ermittelt.

'für unsortierte Spalte A !!!
'getestet! funktioniert!
Sub ident_rows()
startzeile = ActiveCell.Row  'suche aufwärts ab der aktuell aktivierten Zeile
'startspalte = ActiveCell.Column
i = startzeile
abbruch = False 'testet immerbis Spalte ms
msl = 3 'erste Parameterspalte C
ms = 12 'letzte parameterspalte L
geloeschte_zeilen = 0
Do
j = i + 1
gleich = False
Do
   Application.StatusBar = "i=" & i & " j=" & j & " gelöscht=" & geloeschte_zeilen
   
   If abbruch Then
     ist_gleich i, j, 1
     For Spalte = msl To ms
     Select Case Spalte
       Case msl To (ms - 1): Eintrag = "P" 'Spalte C bis K
                             fehlt_eintrag i, Spalte, Eintrag 'ist gelb
       Case ms:      Eintrag = "Q"  'Spalte L
                     fehlt_eintrag i, Spalte, Eintrag, vbRed 'geändert auf Rot
       Case Else:
     End Select
     Next Spalte
   Else 'Spalte immer bis ms testen
     ist_gleich_to_max_spalte i, j, 1, ms 'immer bis Spalte L
   End If
   
   If gleich Then
      Rows(j).Delete
      geloeschte_zeilen = geloeschte_zeilen + 1
   End If
   j = j + 1
Loop Until IsEmpty(Cells(j, 1))
   i = i + 1
Loop Until IsEmpty(Cells(i, 1))
If Not abbruch Then
  i = startzeile
  Do
     For Spalte = msl To ms
     Select Case Spalte
       Case msl To (ms - 1): Eintrag = "P" 'Spalte C bis K
                             fehlt_eintrag i, Spalte, Eintrag 'ist gelb
       Case ms:      Eintrag = "Q"  'Spalte L
                     fehlt_eintrag i, Spalte, Eintrag, vbRed 'geändert auf Rot
       Case Else:
     End Select
     Next Spalte
     i = i + 1
  Loop Until IsEmpty(Cells(i, 1))
End If
End Sub

'für sortierte Spalte A !!!
'für i<>j wird i sofort erhöht
Sub s_ident_rows()

'für s_ident_rows gibts noch Probleme mit der Erkennung,
'wenn abbruch=False gesetzt ist, dann werden u.U.
'nicht alle Zeilen gelöscht,d.h. s_ident_rows sollte
'nur bei Abbruch=true verwendet werden!

startzeile = ActiveCell.Row
'startspalte = ActiveCell.Column
i = startzeile
abbruch = False 'testet immerbis Spalte ms
msl = 3 'erste Parameterspalte C
ms = 12 'letzte parameterspalte L
geloeschte_zeilen = 0

j = i + 1
gleich = False
Do
   Application.StatusBar = "i=" & i & " j=" & j & " gelöscht=" & geloeschte_zeilen
   If abbruch Then
     ist_gleich i, j, 1
     For Spalte = msl To ms ' Spalte C bis L
       Select Case Spalte
         Case msl To (ms - 1): Eintrag = "P" 'Spalte C bis K
                               fehlt_eintrag i, Spalte, Eintrag 'ist gelb
         Case ms:      Eintrag = "Q"  'Spalte L
                       fehlt_eintrag i, Spalte, Eintrag, vbRed
         Case Else:
       End Select
     Next Spalte
   Else
   ist_gleich_to_max_spalte i, j, 1, ms 'immer bis Spalte ms
   End If
   
   If gleich Then
      Rows(j).Delete
      geloeschte_zeilen = geloeschte_zeilen + 1
      j = j + 1
   Else
      j = j + 1
      If Cells(i, 1) <> Cells(j, 1) Then
         i = i + 1
         j = i + 1
      Else
         j = j + 1
      End If
   End If
Loop Until IsEmpty(Cells(j, 1))
If Not abbruch Then
  i = startzeile
  Do
     For Spalte = msl To ms
     Select Case Spalte
       Case msl To (ms - 1): Eintrag = "P" 'Spalte C bis K
                             fehlt_eintrag i, Spalte, Eintrag 'ist gelb
       Case ms:      Eintrag = "Q"  'Spalte L
                     fehlt_eintrag i, Spalte, Eintrag, vbRed
       Case Else:
     End Select
     Next Spalte
     i = i + 1
  Loop Until IsEmpty(Cells(i, 1))
Else
   For Spalte = msl To ms  'Spalte C bis L
   Select Case Spalte
     Case msl To (ms - 1): Eintrag = "P" 'Spalte C bis K
                           fehlt_eintrag i, Spalte, Eintrag 'ist gelb
     Case ms:      Eintrag = "Q"  'Spalte L
                   fehlt_eintrag i, Spalte, Eintrag, vbRed
     Case Else:
   End Select
   Next Spalte
End If
End Sub


'ob es zu Stackproblemen kommt hab ich nicht getestet,
'kann bei Rekursion aber auftreten!

Sub ist_gleich(ByVal a, ByVal b, ByVal ofs)
  ' bricht den Vergleich ab, sowie beide Vergleichszellen leer sind
  
  If IsEmpty(Cells(a, ofs)) And IsEmpty(Cells(b, ofs)) Then Exit Sub
  If Cells(a, ofs).Value = Cells(b, ofs).Value Then
      gleich = True
      ist_gleich a, b, ofs + 1 'rekursiver Test
  Else
      gleich = False
      Exit Sub
  End If
End Sub

Sub ist_gleich_to_max_spalte(ByVal a, ByVal b, ByVal ofs, ms)
  'vergleicht immer bis Zelle in Spalte ms
  If ofs > ms Then Exit Sub
  If IsEmpty(Cells(a, ofs)) And IsEmpty(Cells(b, ofs)) Then
      gleich = True
      ist_gleich_to_max_spalte a, b, ofs + 1, ms 'rekursiver Test
  ElseIf Cells(a, ofs).Value = Cells(b, ofs).Value Then
         gleich = True
         ist_gleich_to_max_spalte a, b, ofs + 1, ms 'rekursiver Test
      Else
         gleich = False
         Exit Sub
  End If
End Sub


'hiermit werden fehlende Einträge ergänzt und farblich markiert
Sub fehlt_eintrag(ByVal a, ByVal ofs, Eintrag As Variant, Optional Farbe = vbYellow)
   If (Not IsEmpty(Cells(a, 1))) And IsEmpty(Cells(a, ofs)) Then
      Cells(a, ofs) = Eintrag
      Cells(a, ofs).Interior.Color = Farbe 'Standard ist Gelb, wenn nicht anders gewählt
   End If
End Sub