Zellen vergleichen, doppelte Zeilen löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Soenke() Dim tx As String Dim i As Long, j As Long, k As Long, laR As Long Application.ScreenUpdating = False laR = Cells(Rows.Count, 2).End(xlUp).Row For i = 1 To laR If Cells(i, 3).Interior.ColorIndex <> 45 Then tx = Cells(i, 2).Value & Cells(i, 4).Value For j = i + 1 To laR + 1 If Cells(j, 2).Value & Cells(j, 4).Value = tx Then If Cells(i, 3).Value < Cells(j, 3).Value Then Cells(i, 3).Interior.ColorIndex = 45 Else Cells(j, 3).Interior.ColorIndex = 45 End If End If Next j End If Next i For k = laR To 1 Step -1 If Cells(k, 3).Interior.ColorIndex = 45 Then Cells(k, 3).EntireRow.Delete End If Next k Application.ScreenUpdating = True End Sub

Hallo Sönke,
bezüglich Excel-Absturz nach Makro-Start habe ich "leider" auch keinen Fehler in meinem Code entdeckt. Vielleicht ist bei einer zu großen Datenmenge hier Excel/VBA (extrem viele Schleifendurchläufe) einfach überfordert. Excel ist ja auch ein Tabellenkalkulationsprogramm und keine Datenbank.
Möglicherweise bist Du in diesem Fall bei Access besser aufgehoben.
Den von Dir beschriebenen Fehler ("Es scheint so, dass Spalte C keine Bedeutung hat, jedenfalls bleibt nur je eine Zeile mit einer "Hauptnummer" aus Spalte B übrig. D.h. alle anderen Zeile mit gleichem Spaltenwert in B, aber anderem in D, werden gelöscht.") kann ich so nicht nachvollziehen.
Ich habe diese Ausgangssituation getestet (Spalten B - C - D):
HUGO 24 OTTO
HUGO 30 KARL
HUGO 36 WILLI
HUGO 22 HANS
HUGO 28 PAUL
HUGO 34 SÖNKE
HUGO 40 OTTO
HUGO 21 KARL
HUGO 27 WILLI
HUGO 33 HANS
HUGO 39 PAUL
HUGO 25 WERNER
HUGO 31 OTTO
HUGO 37 KARL
HUGO 26 WILLI
HUGO 32 HANS
HUGO 38 PAUL
HUGO 23 EUGEN
HUGO 29 EUGEN
HUGO 35 KARL
Nach Durchlauf des Makros bleiben die nachstehenden Zeilen übrig.
Was ist daran falsch?
HUGO 36 WILLI
HUGO 34 SÖNKE
HUGO 40 OTTO
HUGO 33 HANS
HUGO 39 PAUL
HUGO 25 WERNER
HUGO 37 KARL
HUGO 29 EUGEN
Gruß WernerB.

Hallo!
War (zum Glück) nur ein Tippfehler von mir. Das Makro funktioniert schon richtig (Danke!).
Manchmal sieht man halt so einfache Fehler nicht. Aber ein Problem mit der Zeilenanzahl besteht für mich schon. Das Makro braucht zu lange zum Überprüfen. Ich habe eine weitere IF-Anweisung hinzugefügt, es wird jetzt erst mal Spalte B und danach bei Übereinstimmung Spalte D und danach C überprüft. Das geht dann schneller. Aber ich hatte die Idee, wenn die Werte in B geordnet vorliegen (sortieren), dann müsste das Makro doch nur in Spalte B so weit zählen, bis es auf einen neuen Wert trifft, d.h. es würde die Zeilen abschnittsweise durchlaufen (in Deinem Beispiel wäre das nur der Abschnitt "Hugo"). Das müsste die Geschwindigkeit doch erheblich erhöhen, da man nicht alle 7500 Zeilen in der Originaltabelle dürchläuft, sondern nur etwa 50 und dann folgt der nächste Abschnitt.
Dafür wäre doch eine Schleife mit Austrittsbedingung geeignet (wenn neuer Wert in Spalte B, dann...), oder? Doch wie realisiere ich die in VBA? Habe da wohl noch so einige Defizite.
So sieht das Makro bei mir jetzt aus:


Sub Tabelle_überprüfen()
Dim tx As String, tx2 As String
Dim i As Long, j As Long, k As Long, laR As Long
Application.ScreenUpdating = False
laR = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To laR
If Cells(i, 3).Interior.ColorIndex <> 45 Then
tx = Cells(i, 2).Value
tx2 = Cells(i, 4).Value
For j = i + 1 To laR + 1
If Cells(j, 2).Value = tx Then
If Cells(j, 4).Value = tx2 Then
If Cells(i, 3).Value < Cells(j, 3).Value Then
Cells(i, 3).Interior.ColorIndex = 45
Else
Cells(j, 3).Interior.ColorIndex = 45
End If
End If
End If
Next j
End If
Next i
For k = laR To 1 Step -1
If Cells(k, 3).Interior.ColorIndex = 45 Then
Cells(k, 3).EntireRow.Delete
End If
Next k
Application.ScreenUpdating = True
End Sub

Wenn Du mir da noch helfen könntest, dann wäre das Makro für meine Zwecke perfekt.
MFG
Sönke Engemann

Sub Soenke() Dim tx As String Dim i As Long, j As Long, k As Long, laR As Long Application.ScreenUpdating = False laR = Cells(Rows.Count, 2).End(xlUp).Row For i = 1 To laR If Cells(i, 3).Interior.ColorIndex <> 45 Then tx = Cells(i, 2).Value & Cells(i, 4).Value For j = i + 1 To laR + 1 If Cells(i, 2).Value <> Cells(j, 2).Value Then Exit For If Cells(j, 2).Value & Cells(j, 4).Value = tx Then If Cells(i, 3).Value < Cells(j, 3).Value Then Cells(i, 3).Interior.ColorIndex = 45 Else Cells(j, 3).Interior.ColorIndex = 45 End If End If Next j End If Next i For k = laR To 1 Step -1 If Cells(k, 3).Interior.ColorIndex = 45 Then Cells(k, 3).EntireRow.Delete End If Next k Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Zellen vergleichen, doppelte Zeilen löschen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

285 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen vergleichen, doppelte Zeilen löschen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

285 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread