Suchschleife nach Doppelte Zeile.

Sub gleicheWerte_loeschen() ' sucht alle gleichen Zellen (Spalte A,C, F) und löscht die Dim iRow1 As Long, iRow2 As Long, iRowL As Long, LZeile As Long Dim Counter As Integer Dim SpalteA() As Boolean iRowL = WorksheetFunction.CountA(Columns(1)) ReDim SpalteA(1 To iRowL) LZeile = 1 For iRow1 = 1 To iRowL If Not SpalteA(iRow1) = True Then 'prüft ob Zeile bereits coloriert wurde SpalteA(iRow1) = True For iRow2 = iRow1 + 1 To iRowL LZeile = LZeile + 1 If Cells(iRow1, 1).Value = Cells(iRow2, 1) Then SpalteA(iRow2) = True If Cells(iRow2, 1).Value = "KW" Then Cells(iRow2, 1).EntireRow.Interior.ColorIndex = 2 'Macht den Zeilenhintergrund weiß ElseIf Cells(iRow1, 1).Value = Cells(iRow2, 1) _ And Cells(iRow1, 3).Value = Cells(iRow2, 3) _ And Cells(iRow1, 6).Value = Cells(iRow2, 6) Then Rows(iRow2).ClearContents Counter = Counter + 1 End If End If If Counter > 0 Then Rows(iRow1).ClearContents End If Next iRow2 If Counter > 0 And LZeile = iRowL Then Rows(iRow1).ClearContents End If End If Counter = 0 LZeile = 1 Next iRow1 Call ZeilenLoeschen End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub gleicheWerte_loeschen2() ' sucht alle gleichen Zellen (Spalte A,C, F) und löscht die Dim iRowL As Long, zz As Long iRowL = Cells(Rows.Count, 1).End(xlUp).Row Columns(1).Insert With Range(Cells(1, 1), Cells(iRowL, 1)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(iRowL, 7)).Sort _ Key1:=Range("B1"), Order1:=xlAscending, _ Key2:=Range("D1"), Order2:=xlAscending, _ Key3:=Range("G1"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom For zz = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Cells(zz, 2) <> "KW" Then If Cells(zz, 2) = Cells(zz - 1, 2) And _ Cells(zz, 4) = Cells(zz - 1, 4) And _ Cells(zz, 7) = Cells(zz - 1, 7) Then _ Range(Cells(zz, 1), Cells(zz, 7)).ClearContents ' Rows(zz).Delete ' falls ohnehin die ganze Zeile gelöscht werden soll End If Next zz Range(Cells(1, 1), Cells(iRowL, 7)).Sort _ Key1:=Range("A1"), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Columns(1).Delete 'Call ZeilenLoeschen End Sub

Sub gleicheWerte_loeschen() ' sucht alle gleichen Zellen (Spalte A,C, F) und löscht die Dim iRowL As Long, zz As Long iRowL = Cells(Rows.Count, 1).End(xlUp).Row Columns(1).Insert With Range(Cells(1, 1), Cells(iRowL, 1)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("B1"), Order1:=xlAscending, _ Key2:=Range("D1"), Order2:=xlAscending, _ Key3:=Range("G1"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom For zz = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Cells(zz, 2) <> "KW" Then If Cells(zz, 2) = Cells(zz - 1, 2) And _ Cells(zz, 4) = Cells(zz - 1, 4) And _ Cells(zz, 7) = Cells(zz - 1, 7) Then _ ' Range(Cells(zz, 1), Cells(zz, 9)).ClearContents Rows(zz).Delete ' falls ohnehin die ganze Zeile gelöscht werden soll End If End If Next zz Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("A1"), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Columns(1).Delete Columns("A:H").Select Selection.Autofilter Columns.AutoFit Range("1:1").Select End Sub

Sub MehrfacheZeilen_loeschen2() ' sucht alle gleichen Zellen (Spalte A,C, F) und alle gefundenen Zeilen Dim iRowL As Long, zz As Long, gg As Long iRowL = Cells(Rows.Count, 1).End(xlUp).Row Columns(1).Insert With Range(Cells(1, 1), Cells(iRowL, 1)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("B1"), Order1:=xlAscending, _ Key2:=Range("D1"), Order2:=xlAscending, _ Key3:=Range("G1"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom zz = Cells(Rows.Count, 1).End(xlUp).Row While zz > 2 gg = 0 While Cells(zz, 2) <> "KW" And _ Cells(zz, 2) = Cells(zz - 1 - gg, 2) And _ Cells(zz, 4) = Cells(zz - 1 - gg, 4) And _ Cells(zz, 7) = Cells(zz - 1 - gg, 7) gg = gg + 1 Wend If gg > 0 Then Range(Rows(zz - gg), Rows(zz)).Delete zz = zz - gg End If zz = zz - 1 Wend Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("A1"), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Columns(1).Delete End Sub

Sub MehrfacheZeilen_loeschen2() ' sucht alle gleichen Zellen (Spalte A,C, F) und ALLE gefundenen Zeilen Dim iRowL As Long, zz As Long, gg As Long iRowL = Cells(Rows.Count, 1).End(xlUp).Row Columns(1).Insert With Range(Cells(1, 1), Cells(iRowL, 1)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("B1"), Order1:=xlAscending, _ Key2:=Range("D1"), Order2:=xlAscending, _ Key3:=Range("G1"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom zz = Cells(Rows.Count, 1).End(xlUp).Row While zz >= 2 gg = 0 Do While Cells(zz, 2) <> "KW" And _ Cells(zz, 2) = Cells(zz - 1 - gg, 2) And _ Cells(zz, 4) = Cells(zz - 1 - gg, 4) And _ Cells(zz, 7) = Cells(zz - 1 - gg, 7) gg = gg + 1 If gg >= zz - 1 Then Exit Do Loop If gg > 0 Then Range(Rows(zz - gg), Rows(zz)).Delete zz = zz - gg End If zz = zz - 1 Wend Range(Cells(1, 1), Cells(iRowL, 9)).Sort _ Key1:=Range("A1"), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Columns(1).Delete End Sub

Hallo Erich,
hätte nicht gedacht, dass dies hier so schwer zu lösen ist.
Habe die mal eine Testdatei angehängt und drunter was da ja eigentlich rauskommen müsste.
Meiner Meinung nach ist der Fehler jetzt, das er den ganzen Bereich dann löscht.
Range(Rows(zz - gg), Rows(zz)).Delete
Mit der Testdatei kann man dann sehen, dass er Zeile 6-8 löscht, obwohl eigentlich nur 8,6 gelöscht werden müsste.
Ginge es vielleicht zu lösen , wenn man erst die Positionen sortiert (wie du es schon mit der Spalte A machst) dann noch eine Spalte einfügt. Dann für jede gleiche Positionsnummer eine Range macht und bei allen gleichen Zeilen eine "X" in die neue Zeile setzt und dann löscht. es darf aber nur ein X gesetzt werden, wenn wirklich alle gleich sind. Wenn z.B. 4 Positioen da sind und es 2x mit Wert 1 und 2x mit Wert 2, dann sollten alle stehen bleiben.
Vielleicht erkläre ich mal den Hintergrund.
Diese Blatt ist das die Summe aus vielen Blättern und nun muss nach Fehlern gesucht werden. Es darf jede gleiche Position nur mit den selben Werten da sein und wenn ich zwar sehe, das eine Zeile falsch ist, aber nicht weiß welche anders sind, sucht mal sich ja dann zu Tode bis ich die anderen gefunden habe.
Wenn es Dir aber jetzt zu streßig wird, sag es mir einfach. Du hast ja schon richtig Zeit für mich investiert. Wäre froh wenn ich schon so fit wie du wäre. Dann müsste ich nicht die Leut hier so nerven :-) Aber hier lernt man richtig was.
Hier mal eine Beispieldatei.

Die Datei https://www.herber.de/bbs/user/34415.xls wurde aus Datenschutzgründen gelöscht

Vielen Dank für deine Hilfe.
mfg
Kay

Hi Kay,
so ganz sauber war meine letzte Version nicht - sie kann bei der 1. Zeile Probleme machen.
Hier eine hoffentlich bessere neue Version, und danach das Ganze noch mal als Prozedur
mit Parametern und einem Testaufruf:

Sub IdentischeGruppenLoeschen()
'  sucht Gruppen von Zeilen mit gleichem Key in Spalte A und löscht die Gruppe,
'  wenn alle Zellen in den Spalten C und F übereinstimmen.
'  (Wenn ein Wert in Spalte C oder F abweicht, bleibt die ganze Gruppe stehen.)
'  Die Gruppe mit dem Key "KW" bleibt immer stehen.
Dim iRowL As Long, zz As Long, gg As Long, alleGleich As Boolean
iRowL = Cells(Rows.Count, 1).End(xlUp).Row         ' Anzahl Key-Zeilen
If iRowL = 1 Then Exit Sub
Columns(1).Insert: Columns(1).NumberFormat = "0"   ' neue Spalte
With Range(Cells(1, 1), Cells(iRowL, 1))           ' für
.Formula = "=ROW()": .Value = .Value            ' Zeilennummern (Werte)
End With
' Sort nach Gruppenkey
Range(Cells(1, 1), Cells(iRowL, 9)).Sort _
Key1:=Range("B1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
zz = iRowL
While zz > 1                                       ' Schleife rückwärts
gg = 1:           alleGleich = True
Do While Cells(zz, 2) = Cells(zz - gg, 2)
If Cells(zz, 4) <> Cells(zz - gg, 4) Or _
Cells(zz, 7) <> Cells(zz - gg, 7) Then alleGleich = False
gg = gg + 1:   If zz = gg Then Exit Do
Loop
If alleGleich And gg > 1 And Cells(zz, 2) <> "KW" Then
Range(Rows(zz - gg + 1), Rows(zz)).Delete    ' gg identische Zeilen löschen
iRowL = iRowL - gg
End If
zz = zz - gg
Wend
' (Zurück-)Sort nach Zeilennummern
Range(Cells(1, 1), Cells(iRowL, 9)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(1).Delete                                  ' Zeilennummern-Spalte löschen
End Sub
Sub Test_prcIdentGruppenLoeschen()
Dim arr(10 To 11) As Integer
arr(10) = 3
arr(11) = 6
'                          A  H        C F
prcIdentGruppenLoeschen 1, 8, "KW", arr
End Sub
'  Die Prozedur gruppiert Zeilen mit gleichem Key (in Spalte iKey) und löscht die Gruppe,
'  wenn alle Zeile der Gruppe auch in den in arrP aufgeführten Spalten übereinstimmen.
'  (Wenn ein Wert in einer geprüften Spalte abweicht, bleibt die ganze Gruppe stehen.)
'  Die Gruppe mit dem in strOK vorgegebenen Key (z. B. Überschriften) bleibt immer stehen.
'  Beim Sortieren werden iAnzS Spalten (und die Zeilennummern-Spalte) berücksichtigt.
Sub prcIdentGruppenLoeschen(ByVal iKey As Integer, iAnzS As Integer, _
strOK As String, arrP() As Integer)
Dim lngZ As Long, zz As Long, gg As Long, ii As Integer, bLoe As Boolean
lngZ = Cells(Rows.Count, iKey).End(xlUp).Row      ' Anzahl Key-Zeilen
If lngZ = 1 Then Exit Sub
Columns(1).Insert                                  ' neue
Columns(1).NumberFormat = "0"                      ' Spalte 1
With Range(Cells(1, 1), Cells(lngZ, 1))            ' für
.Formula = "=ROW()": .Value = .Value            ' Zeilennummern (Werte)
End With
iKey = iKey + 1                                    ' Sort nach Gruppenkey
Range(Cells(1, 1), Cells(lngZ, iAnzS + 1)).Sort _
Key1:=Cells(1, iKey), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
zz = lngZ
While zz > 1                                       ' Zeilen-Schleife rückwärts
bLoe = True
gg = 1
Do While Cells(zz, iKey) = Cells(zz - gg, iKey) ' innerhalb einer Gruppe
For ii = LBound(arrP) To UBound(arrP)        ' Spalten-Schleife
If arrP(ii) > 0 Then _
If Cells(zz, arrP(ii) + 1) <> Cells(zz - gg, arrP(ii) + 1) Then bLoe = False
Next ii
gg = gg + 1:   If zz = gg Then Exit Do
Loop
If bLoe And gg > 1 And Cells(zz, iKey) <> strOK Then
Range(Rows(zz - gg + 1), Rows(zz)).Delete    ' Gruppe löschen (gg Zeilen)
lngZ = lngZ - gg
End If
zz = zz - gg
Wend                                               ' (Zurück-)Sort nach Zeilennummern
Range(Cells(1, 1), Cells(lngZ, iAnzS + 1)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(1).Delete                                  ' Zeilennummern löschen
End Sub

Zu den Schleifen: "While" ist einfacher, dafür bietet "Do" mehr Möglichkeiten.
Ein Buch oder so zu nennen ist schwierig, zu anhängig von Vorkenntnissen und dem Ziel.
Ich hab 1997 angefangen mit der damaligen Version von Michael Kofler: "Excel-VBA programmieren". Das hat mir geholfen.
Viel Spaß beim Testen und Analysieren!
Grüße von Erich aus Kamp-Lintfort

Sub prcIdentGruppenLoeschen verstehte ich jetzt kaum noch was (lBound, Ubound). Was macht den die Test_prc..... ? Sub Test_prcIdentGruppenLoeschen() prcIdentGruppenLoeschen 1, 8, "KW", arr End Sub Sub prcIdentGruppenLoeschen Hast du vielleicht noch einen Tipp, wie ich den Code so hingehend verbessern könnte, das die jeweilige KW hinter den zu gehörigen Einträgen geschrieben wird? So könnte ich nämlich mit dem Autofilter besser nach einer Position filtern und feststellen wo die Abweichung ist? Bis man nämlich bei vielen Fehler den Überblick hat, muss man andauernd den Filter an und ausschalten. mfg Kay

Beliebteste Forumthreads (12 Monate)

Suchschleife nach Doppelte Zeile.

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread