Über mehrere Tabellen Zeilen löschen

Sub LeereZeilenLöschen() HDB = "gesamt" For i = Sheets(HDB).index + 1 To Sheets.Count a = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row For zz = a To 7 Step -1 strName = "" For Each e In Sheets(i).Range("F" & zz & ":IV" & zz) strName = strName & e.Value Next e If strName = "" Then Sheets(i).Range("A" & zz).EntireRow.Delete Next zz Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub LeereZeilenLöschen() Dim ii As Integer, zz As Long, rngF As Range Const HDB = "gesamt" For ii = Sheets(HDB).Index + 1 To Sheets.Count With Sheets(ii) For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1 Set rngF = Range(.Cells(7, 6), .Cells(zz, 256)).Find(What:="*", _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngF Is Nothing Then Range(.Rows(7), .Rows(zz)).Delete Exit Sub ElseIf rngF.Row < zz Then Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete zz = rngF.Row End If Next zz End With Next ii End Sub

Option Explicit Sub LeereZeilenLöschen() Dim ii As Integer, zz As Long, rngF As Range Const HDB = "gesamt" Dim Calc As XlCalculation Calc = Application.Calculation Beschleuniger xlCalculationManual For ii = Sheets(HDB).Index + 1 To Sheets.Count With Sheets(ii) For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1 Set rngF = Range(.Cells(7, 6), .Cells(zz, 256)).Find(What:="*", _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngF Is Nothing Then Range(.Rows(7), .Rows(zz)).Delete Exit Sub ElseIf rngF.Row < zz Then Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete zz = rngF.Row End If Next zz End With Next ii Beschleuniger Calc End Sub ' Beschleuniger _______ Parameter: Calc-Status ______ gi/12.03.2006 'Aufruf: ' Dim Calc As XlCalculation ' Calc = Application.Calculation: Beschleuniger xlCalculationManual ' ....Code.... ' Beschleuniger Calc Sub Beschleuniger(StatCal As XlCalculation) Application.Calculation = StatCal If StatCal = xlCalculationManual Then Application.ScreenUpdating = False Else Application.ScreenUpdating = True End If End Sub

Sub LeereZeilenLöschen() Dim ii As Integer, zz As Long, rngF As Range Const HDB = "gesamt" Dim Calc As XlCalculation Calc = Application.Calculation Beschleuniger xlCalculationManual For ii = Sheets(HDB).Index + 1 To Sheets.Count With Sheets(ii) For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1 Set rngF = Range(.Cells(7, 6), .Cells(zz, 256)).Find(What:="*", _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngF Is Nothing Then Range(.Rows(7), .Rows(zz)).Delete GoTo XEnd ElseIf rngF.Row < zz Then Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete zz = rngF.Row End If Next zz End With Next ii XEnd: Beschleuniger Calc End Sub

Sub NullSpalten_LeerZeilen_Löschen() Dim ii As Integer, zz As Long, rngF As Range Dim ssV As Integer, ssB As Integer, ssAnz As Integer Const HDB = "gesamt" Dim Calc As XlCalculation Calc = Application.Calculation Beschleuniger xlCalculationManual For ii = Sheets(HDB).Index + 1 To Sheets.Count With Sheets(ii) ' ------------------------------------------------- Spalten löschen ssB = 256 Do While ssB > 7 Do While ssB > 7 And Cells(4, ssB) <> 0 ssB = ssB - 1 Loop ssV = ssB + 1 Do While ssV > 7 And Cells(4, ssV - 1) = 0 ssV = ssV - 1 Loop If ssV <= ssB Then Range(Columns(ssV), Columns(ssB)).Delete ssAnz = ssAnz + ssB - ssV + 1 ssB = ssV - 1 End If Loop ' ------------------------------------------------- Zeilen löschen For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1 Set rngF = Range(.Cells(7, 6), .Cells(zz, 256 - ssAnz)).Find(What:="*", _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngF Is Nothing Then Range(.Rows(7), .Rows(zz)).Delete GoTo XEnd ElseIf rngF.Row < zz Then Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete zz = rngF.Row End If Next zz End With Next ii XEnd: Beschleuniger Calc End Sub

Hi Erich,
sorry das ich mich erst jetzt melde.
Echt klasse!!! Vielen Dank nochmal für deine Hilfe.
waren zwar noch kleine Fehler drin, aber jetzt klappts:
Die Punkte haben gefehlt z.b. bei: .Cells, .Range, .Columns
hab bei die 0en in "0", sonst löscht es mir alle Spalten (in Zeile 4,die mit Summenwert 0 und die keinen Inhalt in der Zelle haben). Jetzt löscht es nur die mit Summenwert 0 raus.


Sub NullSpalten_LeerZeilen_Löschen()
Dim ii As Integer, zz As Long, rngF As Range
Dim ssV As Integer, ssB As Integer, ssAnz As Integer
Const HDB = "gesamt"
Dim Calc As XlCalculation
Calc = Application.Calculation
Beschleuniger xlCalculationManual
For ii = Sheets(HDB).Index + 1 To Sheets.Count
With Sheets(ii)
' ------------------------------------------------- Spalten löschen
ssB = 256
Do While ssB > 7
Do While ssB > 7 And .Cells(4, ssB) <> "0"
ssB = ssB - 1
Loop
ssV = ssB + 1
Do While ssV > 7 And .Cells(4, ssV - 1) = "0"
ssV = ssV - 1
Loop
If ssV <= ssB Then
.Range(.Columns(ssV), .Columns(ssB)).Delete
ssAnz = ssAnz + ssB - ssV + 1
ssB = ssV - 1
End If
Loop
' ------------------------------------------------- Zeilen löschen
For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1
Set rngF = Range(.Cells(7, 6), .Cells(zz, 256)).Find(What:="*", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rngF Is Nothing Then
Range(.Rows(7), .Rows(zz)).Delete
GoTo XEnd
ElseIf rngF.Row < zz Then
Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete
zz = rngF.Row
End If
Next zz
End With
XEnd:
Beschleuniger Calc
Next ii
End Sub

Hast du vielleicht (möchte dich nicht nerven:)) eine Idee, wie man schnell den einen Druckbereich für den benutzten Bereich für diese Blätter festlegen kann? Hab hier schon ein Skript, aber vielleicht fällt dir noch etwas dazu ein?
For i = Sheets(HDB).Index + 1 To Sheets.Count
'letzte benutzte Zeile ermitteln
LetzteZeile = Sheets(i).UsedRange.Rows.Count + 5
'letzte benutzte Spalte ermitteln
intNr = Sheets(i).UsedRange.Columns.Count - 3 'hier steuert man, welche Spalten weggelassen werden
'Ermitteln des Spalten-Buchstabens
On Error Resume Next
Cells(1, intNr).Select
ac = ActiveCell.Address
ab = Right(ac, Len(ac) - 1)
ac = Left(ab, Len(ab) - 2)
'Druckbereich festlegen
Sheets(i).PageSetup.PrintArea = ("A1:" & ac & LetzteZeile)
Next i
Application.ScreenUpdating = True
End Sub
Gruß Julia

Sub NullSpalten_LeerZeilen_Löschen() Dim ii As Integer, zz As Long, rngF As Range Dim ssV As Integer, ssB As Integer, ssAnz As Integer Const HDB = "gesamt" Dim Calc As XlCalculation Calc = Application.Calculation Beschleuniger xlCalculationManual For ii = Sheets(HDB).Index + 1 To Sheets.Count With Sheets(ii) ' ------------------------------------------------- Spalten löschen ssB = 256 Do While ssB > 7 Do While ssB > 7 And .Cells(4, ssB) <> "0" ssB = ssB - 1 Loop ssV = ssB + 1 Do While ssV > 7 And .Cells(4, ssV - 1) = "0" ssV = ssV - 1 Loop If ssV <= ssB Then Range(.Columns(ssV), .Columns(ssB)).Delete ssAnz = ssAnz + ssB - ssV + 1 ssB = ssV - 1 End If Loop ' ------------------------------------------------- Zeilen löschen For zz = .Cells(Rows.Count, 1).End(xlUp).Row To 7 Step -1 Set rngF = Range(.Cells(7, 6), .Cells(zz, 256 - ssAnz)).Find(What:="*", _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngF Is Nothing Then Range(.Rows(7), .Rows(zz)).Delete Exit For ElseIf rngF.Row < zz Then Range(.Rows(rngF.Row + 1), .Rows(zz)).Delete zz = rngF.Row End If Next zz ' ------------------------------------------------- Druckbereich festlegen zz = .Cells(Rows.Count, 1).End(xlUp).Row ' Spalte A ist maßgebend ssB = .Cells(4, Columns.Count).End(xlToLeft).Column ' Zeile 4 ist maßgebend Sheets(ii).PageSetup.PrintArea = Range(.Cells(1, 1), .Cells(zz, ssB)).Address End With Next ii Beschleuniger Calc End Sub

Hi Erich,
nett, dass du Dich nochmal gemeldet hast!
Wenn man das Skript beim ersten Mal ablaufen lässt, läuft es super schnell, doch wenn man es mehrmals hintereinander benutzt, ist es um einiges langsamer als zuvor?:(?
Was mich auch wundert, dass das Skript so langsam ist, wenn man bei
Sheets(ii).PageSetup.PrintArea = Range(.Cells(1, 1)
nachfolgend z. b. noch einige Befehle für die Druckeigenschaften hinzufügt:
Sheet(ii).PrintTitleRows = WZE
Sheet(ii).PrintTitleColumns = WSP
Sheet(ii).RightFooter = "&10" & "Seite " & pj & "&P/&N"
Sheet(ii).PrintGridlines = True
Sheet(ii).Orientation = xlPortrait
Sheet(ii).BlackAndWhite = True
Sheet(ii).Zoom = 90
Hast du eine Ahnung was da los ist? Muss man vielleicht irgendwas reseten?!?!?
Gruß Julia

' ------------------------------------------------- Druckbereich festlegen zz = .Cells(Rows.Count, 1).End(xlUp).Row ' Spalte A ist maßgebend ssB = .Cells(4, Columns.Count).End(xlToLeft).Column ' Zeile 4 ist maßgebend .PageSetup.PrintArea = Range(.Cells(1, 1), .Cells(zz, ssB)).Address With .PageSetup If .Orientation <> xlPortrait Then .Orientation = xlPortrait End With End With Next ii Beschleuniger Calc End Sub

Beliebteste Forumthreads (12 Monate)

Über mehrere Tabellen Zeilen löschen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Über mehrere Tabellen Zeilen löschen

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

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread