Zeilen löschen

Sub loesche_Leerzeilen() Dim ActRow, LastRow LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row ActRow = 1 While (ActRow < LastRow) If (IsEmpty(Cells(ActRow, 1))) Then Rows(ActRow).Delete LastRow = LastRow - 1 Else ActRow = ActRow + 1 End If Wend End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub loesche_Leerzeilen() Dim ActRow, LastRow LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row ActRow = 1 While (ActRow < LastRow) If application.worksheetfunction.counta(Range(cells(actrow,1),cells(actrow,5)))<5 Then Rows(ActRow).Delete LastRow = LastRow - 1 Else ActRow = ActRow + 1 End If Wend End Sub

Sub Benny() Dim i As Long Application.ScreenUpdating = False For i = 15 To 4 Step -1 If WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).Delete End If Next i Application.ScreenUpdating = True End Sub

Sub Benny() Dim i As Long, _ z1 As Byte, z2 As Byte Application.ScreenUpdating = False With Worksheets("Tabelle1") z1 = 15 For i = 15 To 4 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 .Rows(i).Delete End If Next i End With With Worksheets("Tabelle2") z2 = 55 For i = 55 To 44 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With Sheets.Add After:=Sheets(Sheets.Count) Worksheets("Tabelle1").Range("A4:IV" & z1).Copy _ Destination:=Worksheets(Sheets.Count).Range("A1") Application.CutCopyMode = False Worksheets("Tabelle2").Range("A44:IV" & z2).Copy _ Destination:=Worksheets(Sheets.Count).Range("A" & z1 - 2) Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Sub Benny() Dim i As Long, _ z1 As Byte, z2 As Byte Application.ScreenUpdating = False With Worksheets("Tabelle1") z1 = 15 For i = 15 To 4 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 .Rows(i).Delete End If Next i z2 = 55 For i = 55 To 44 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With With Worksheets("Tabelle2") z1 = 15 For i = 15 To 4 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 .Rows(i).Delete End If Next i z2 = 55 For i = 55 To 44 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With Sheets.Add After:=Sheets(Sheets.Count) Worksheets("Tabelle1").Range("A4:IV" & z1).Copy _ Destination:=Worksheets(Sheets.Count).Range("A1") Application.CutCopyMode = False Worksheets("Tabelle2").Range("A44:IV" & z2).Copy _ Destination:=Worksheets(Sheets.Count).Range("A" & z1 - 2) Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Sub Benny() Dim i As Long, laR As Long, _ z1 As Byte, z2 As Byte, z3 As Byte, j As Byte Application.ScreenUpdating = False Sheets.Add After:=Sheets(Sheets.Count) For j = 1 To 2 With Worksheets("Tabelle" & j) z1 = 15 z3 = 44 For i = 15 To 4 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 z3 = z3 - 1 .Rows(i).Delete End If Next i z2 = z3 + 11 For i = z3 + 11 To z3 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With With Worksheets(Sheets.Count) On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row If laR = 1 And .Cells(1, 1).Value = "" Then laR = 0 On Error GoTo 0 Worksheets("Tabelle" & j).Range("A4:IV" & z1).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 Worksheets("Tabelle" & j).Range("A" & z3 & ":IV" & z2).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False End With Next j Application.ScreenUpdating = True End Sub

Sub losche_Leerzeilen_kopiere_Rest() Dim i As Long, laR As Long, _ z1 As Byte, z2 As Byte, z3 As Byte, j As Byte Application.ScreenUpdating = False Sheets.Add After:=Sheets(Sheets.Count) For j = 1 To 2 With Worksheets("0" & j) z1 = 15 z3 = 44 For i = 15 To 4 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 z3 = z3 - 1 .Rows(i).Delete End If Next i z2 = z3 + 11 For i = z3 + 11 To z3 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With With Worksheets(Sheets.Count) On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 Worksheets("0" & j).Range("A4:IV" & z1).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False End With Next j Application.ScreenUpdating = True End Sub

Hallo Werner,
nach einigen Tests und verändern diverser Werte, ist das Makro nun fast so wie gewünscht. Deine Frage nach der Sinnhaftigkeit erklärt sich dadurch, dass ich nicht wußte das ein abprüfen einer Zeile auf "Leer" auch auf Formeln greift.
Nun würde ich das Makro noch ein bißchen ausbauen wollen.
Die weiteren Schritte in dem neuen Tabellenblatt stelle ich mir wie folgt vor:
1.) umbenennen den neuen Tabellenblattes in SuS
2.) Spalte A markieren
3.) Bearbeiten - Gehe zu - Inhalte - Leerzellen anklicken
4.) Bearbeiten - Zellen löschen - Ganze Zeile
5.) Sortieren nach Spalte F - B - A (wenn möglich, ansonsten auflösen der Formatierung, dann sortieren und zum Schluss die Formatierung wieder übertragen)
Das würde ich über einen Makrorkorder aufzeichnen und in das u.a. Makro integrieren. Jedoch habe ich beim sortieren so meine Schwierigkeiten. Kannst du mir auch dort helfen.


Sub losche_Leerzeilen_kopiere_Rest()
Dim i As Long, laR As Long, _
z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
Application.ScreenUpdating = False
Sheets.Add After:=Sheets(Sheets.Count)
For j = 1 To 2
With Worksheets("0" & j)
z1 = 41
z3 = 53
For i = 41 To 6 Step -1
If WorksheetFunction.CountA(.Rows(i)) = 0 Then
z1 = z1 - 1
z3 = z3 - 1
.Rows(i).Delete
End If
Next i
z2 = z3 + 36
For i = z3 + 12 To z3 Step -1
If WorksheetFunction.CountA(.Rows(i)) = 0 Then
z2 = z2 - 1
.Rows(i).Delete
End If
Next i
End With
With Worksheets(Sheets.Count)
On Error Resume Next
laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
On Error GoTo 0
Worksheets("0" & j).Range("A4:IV" & z1).Copy _
Destination:=.Range("A" & laR + 1)
Application.CutCopyMode = False
On Error Resume Next
laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
On Error GoTo 0
Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _
Destination:=.Range("A" & laR + 1)
Application.CutCopyMode = False
End With
Next j
Application.ScreenUpdating = True
End Sub

Viele Grüße
Benny

Sub losche_Leerzeilen_kopiere_Rest() Dim Adr As String, _ i As Long, laR As Long, _ z1 As Byte, z2 As Byte, z3 As Byte, j As Byte Application.ScreenUpdating = False Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).name = "SuS" For j = 1 To 2 With Worksheets("0" & j) z1 = 41 z3 = 53 For i = 41 To 6 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z1 = z1 - 1 z3 = z3 - 1 .Rows(i).Delete End If Next i z2 = z3 + 36 For i = z3 + 12 To z3 Step -1 If WorksheetFunction.CountA(.Rows(i)) = 0 Then z2 = z2 - 1 .Rows(i).Delete End If Next i End With With Worksheets(Sheets.Count) On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 Worksheets("0" & j).Range("A4:IV" & z1).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _ Destination:=.Range("A" & laR + 1) Application.CutCopyMode = False End With Next j With Worksheets(Sheets.Count) On Error Resume Next laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row On Error GoTo 0 If laR = 0 Then Exit Sub .Range("A1:A" & laR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Adr = .Cells(.Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row, _ .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column).Address .Range("A1:" & Adr).Sort Key1:=.Range("F1"), Order1:=xlAscending, Key2:=.Range("B1"), _ Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal End With Application.ScreenUpdating = True End Sub

Hallo Werner,
leider bleibt das Makro an der u.a. Stelle mit folgender Fehlermeldung stehen.
Laufzeitfehler (1004)
Für diese Aktionen müssen alle verbundenen Zellen dieselbe Größe haben
.Range("A1:" & Adr).Sort Key1:=.Range("F1"), Order1:=xlAscending, Key2:=.Range("B1"), _
Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Was wäre wenn man erst die Formatierung löst dann sortiert und hinterher die Formatierung wieder setzt.
Oder es wird das Blatt SuS erst in SuS1 kopiert, dann dort die Formatierung gelöst, sortiert und die Formatierung von SuS übernommen. Danach wird das Blatt SuS gelöscht und SuS1 in SuS umbenannt.
Sorry aber kannst du mir auch dabei helfen.
Gruß
Benny

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread