Alle komplett leeren ZEILEN löschen

Sub LeereZeilenLöschen() Dim tmp Dim x Application.ScreenUpdating = False ActiveSheet.Unprotect Password:=passw tmp = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row For x = tmp To 1 Step -1 Do While Application.CountA(Rows(x)) = False Rows(x).EntireRow.Delete Loop Next x End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
das Makro müsste man so anpassen.

Sub LeereZeilenLöschen(strDatei As String, strTabelle As String)
Dim LRowValue As Long, LRowFormula As Long, A As Long
Dim Zelle As Range, tempZelle As Range
'ActiveSheet.Unprotect "xxx" 
     
With Workbooks(strDatei).Sheets(strTabelle)
    On Error Resume Next
        LRowValue = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
        LRowFormula = .Cells.Find("*", , xlFormulas, 2, 1, 2, False, False, False).Row
    On Error GoTo 0

        For A = 1 To IIf(LRowValue > LRowFormula, LRowValue, LRowFormula)
          Set tempZelle = .Range(.Cells(A, 1), IIf(IsEmpty(.Cells(A, .Columns.Count)), .Cells(A, .Columns.Count).End(xlToLeft), .Cells(A, .Columns.Count)))
            
            If CheckString(tempZelle) Then
               If Zelle Is Nothing Then
                 Set Zelle = .Cells(A, 1)
               Else
                 Set Zelle = Union(Zelle, .Cells(A, 1))
               End If
            End If
        
        Next A
End With
    Application.ScreenUpdating = False
     If Not Zelle Is Nothing Then Zelle.EntireRow.Delete
    Application.ScreenUpdating = True
'ActiveSheet.Protect "xxx" 
End Sub

Private Function CheckString(ByVal rngBereich As Range) As Boolean
Dim strString As String

If rngBereich.Cells.Count > 1 Then
 strString = Join(Application.Transpose(Application.Transpose(rngBereich)), "")
Else
 strString = rngBereich
End If

Der Aufruf aus einer anderen Datei, müsste so aussehen.

 'Die Dateinamen und die Tabellennamen, musst Du entsprechend anpassen! 
 Application.Run "'DateiLöschMakro.xls'!LeereZeilenLöschen", "Anwenden_Auf.xls", "Tabelle1"

Gruß Tino

Sub LeereZeilenLöschen() Dim LRowValue As Long, LRowFormula As Long, A As Long Dim Zelle As Range 'ActiveSheet.Unprotect "xxx" On Error Resume Next LRowValue = Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row LRowFormula = Cells.Find("*", , xlFormulas, 2, 1, 2, False, False, False).Row On Error GoTo 0 With Application.WorksheetFunction For A = 1 To .Max(LRowValue, LRowFormula) If .CountBlank(Rows(A)) = Columns.Count Then If Zelle Is Nothing Then Set Zelle = Cells(A, 1) Else Set Zelle = Union(Zelle, Cells(A, 1)) End If End If Next A End With Application.ScreenUpdating = False If Not Zelle Is Nothing Then Zelle.EntireRow.Delete Application.ScreenUpdating = True 'ActiveSheet.Protect "xxx" End Sub

Option Explicit Sub LeereZeilenLöschen() Dim LRowValue As Long, LRowFormula As Long, A As Long Dim Zelle As Range, tempZelle As Range 'ActiveSheet.Unprotect "xxx" On Error Resume Next LRowValue = Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row LRowFormula = Cells.Find("*", , xlFormulas, 2, 1, 2, False, False, False).Row On Error GoTo 0 For A = 1 To IIf(LRowValue > LRowFormula, LRowValue, LRowFormula) Set tempZelle = Range(Cells(A, 1), IIf(IsEmpty(Cells(A, Columns.Count)), Cells(A, Columns.Count).End(xlToLeft), Cells(A, Columns.Count))) If CheckString(tempZelle) Then If Zelle Is Nothing Then Set Zelle = Cells(A, 1) Else Set Zelle = Union(Zelle, Cells(A, 1)) End If End If Next A Application.ScreenUpdating = False If Not Zelle Is Nothing Then Zelle.EntireRow.Delete Application.ScreenUpdating = True 'ActiveSheet.Protect "xxx" End Sub Private Function CheckString(rngBereich As Range) As Boolean Dim objRegExp As Object Dim strString As String If rngBereich.Cells.Count > 1 Then strString = Join(Application.Transpose(Application.Transpose(rngBereich)), "") Else strString = rngBereich End If Set objRegExp = CreateObject("vbscript.regexp") With objRegExp .Global = True .Pattern = "\s" .IgnoreCase = True CheckString = (.Replace(strString, "") = "") End With Set objRegExp = Nothing End Function

Sub LeereZeilenLöschen() Dim LRowValue As Long, LRowFormula As Long, A As Long Dim Zelle As Range, tempZelle As Range 'ActiveSheet.Unprotect "xxx" On Error Resume Next LRowValue = Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row LRowFormula = Cells.Find("*", , xlFormulas, 2, 1, 2, False, False, False).Row On Error GoTo 0 For A = 1 To IIf(LRowValue > LRowFormula, LRowValue, LRowFormula) Set tempZelle = Range(Cells(A, 1), IIf(IsEmpty(Cells(A, Columns.Count)), Cells(A, Columns.Count).End(xlToLeft), Cells(A, Columns.Count))) If CheckString(tempZelle) Then If Zelle Is Nothing Then Set Zelle = Cells(A, 1) Else Set Zelle = Union(Zelle, Cells(A, 1)) End If End If Next A Application.ScreenUpdating = False If Not Zelle Is Nothing Then Zelle.EntireRow.Delete Application.ScreenUpdating = True 'ActiveSheet.Protect "xxx" End Sub Private Function CheckString(ByVal rngBereich As Range) As Boolean Dim strString As String If rngBereich.Cells.Count > 1 Then strString = Join(Application.Transpose(Application.Transpose(rngBereich)), "") Else strString = rngBereich End If CheckString = _ (Application.WorksheetFunction.Clean(strString) = "") Or _ (Trim$(strString) = "") End Function

Beliebteste Forumthreads (12 Monate)

Alle komplett leeren ZEILEN löschen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Alle komplett leeren ZEILEN löschen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread