Zeilen Löschen mit Schleife
18.04.2016 19:07:12
Michael
Hi zusammen,
das sollte es tun: https://www.herber.de/bbs/user/105056.xls
Das Makro:
Option Explicit
Private Sub CommandButton1_Click()
Dim LastRow As Long
Dim LastCol As Long, LCres As Long
Dim x1 As Variant, x2 As Variant
Dim y1 As String, y2 As String
Dim i As Long, k As Long, jmax1&, jmax2&, j1&, j2&, j&
Dim z1 As Variant, z2 As Variant, ausgabe As Variant
Dim gerade As Boolean, gefunden As Boolean
Dim c As Range
LastRow = Cells(Rows.Count, 12).End(xlUp).Row
LastCol = 52: LCres = LastCol - 11
ausgabe = Range("BA1").Resize(LastRow, 1)
gerade = False
Range("L" & 1).Resize(, LCres).Interior.Color = vbYellow
MsgBox "zunächst wurde gefärbt, um den Bereich zu überprüfen"
ausgabe(2, 1) = 2
z1 = Range("L" & 2).Resize(, LCres)
For i = 3 To LastRow
If gerade Then
z1 = Range("L" & i).Resize(, LCres)
Else
z2 = Range("L" & i).Resize(, LCres)
End If
gerade = Not gerade
ausgabe(i, 1) = i
j = 0
' zuerst werden Nicht-Leere "nach oben" sortiert
For k = 1 To LCres
If Not IsEmpty(z1(1, k)) Then
j = j + 1
z1(1, j) = z1(1, k)
End If
Next
jmax1 = j
' Stop
j = 0
For k = 1 To LCres
If Not IsEmpty(z2(1, k)) Then
j = j + 1
z2(1, j) = z2(1, k)
End If
Next
jmax2 = j
' WENN gleich viel Zellen MIT Werten
If jmax1 = jmax2 Then
For j1 = 1 To jmax1
gefunden = False
For j2 = 1 To jmax2
If z1(1, j1) = z2(1, j2) Then
gefunden = True
Exit For
End If
Next
If Not gefunden Then Exit For
Next
Else
gefunden = False
End If
If gefunden Then ausgabe(i, 1) = LastRow + 1
Next i
Range("BA1").Resize(LastRow, 1) = ausgabe
MsgBox "Die Werte wurden in Spalte BA geschrieben"
Range("A2:BA" & LastRow).Sort key1:=Range("BA2")
MsgBox "und sortiert"
'Stop
Set c = Range("BA2:BA" & LastRow).Find(LastRow + 1)
If Not c Is Nothing Then
c.Interior.Color = vbGreen
MsgBox "Ab Zelle " & c.Address & " wird gelöscht"
Rows(c.Row & ":" & LastRow).EntireRow.Delete
End If
End Sub
Schöne Grüße & Antwort erbeten,
Michael