Alle komplett leeren ZEILEN löschen

Forumthread: Alle komplett leeren ZEILEN löschen

14.03.2009 00:09:37

Tobias

Hallo allesamt,
ich würde gerne alle Zeilen Löschen, wenn nichts in den zellen steht
habs hiermit versucht:


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

Bekomme aber 1004 : Die Delete-Methode des Range Objektes konnte nicht ausgeführt werden?
Woran liegt das?
Lg Tobias

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Alle komplett leeren ZEILEN löschen

14.03.2009 06:46:55

robert

hi,
schau mal diesen beitrag, vielleicht hilft's
gruß
robert
Zeile mit optisch leerer Zelle löschen von Werner R. vom 13.03.2009 11:21:32

AW: Alle komplett leeren ZEILEN löschen

14.03.2009 18:36:26

Tobias

Hallo Tino,
vielen Dank,
endlich klappts!
Was muss ich den ändern, dass ich dieses makro aus einem anderem tabellenblatt so aufrufen kann:
Call LeereZeilenLöschen("Dateiname.xls".Tabellenblattname)
Ich hab ein paar Ansätze versucht, scheitere aber hoffnungslos :(
Beste Grüsse,
Tobias
PS: wo kann ich denn die geheimen tags einsehen, mit denen ihr mehrfärbigen Code, tabellen etc... in forumspostings einbaut? (in diesem forum)

AW: Alle komplett leeren ZEILEN löschen

14.03.2009 19:48:16

Tino

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

Thanx, mate! ;) o.t.

15.03.2009 16:14:38

Tobias

AW: Alle komplett leeren ZEILEN löschen

14.03.2009 10:16:39

Tino

Hallo,
wenn es sich um wirklich leere Zellen Handelt, kannst du es so mal versuchen.
Sind aber in den Zeilen auch Zellen enthalten die nur optisch leer sind,
also auch Umbruchzeichen oder Leerzeichen endhalten, müsste man dies anders lösen.

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

Gruß Tino

optisch leere

14.03.2009 13:24:23

Tino

Hallo,
hier mal eine Möglichkeit um auch optisch leere Zeilen zu finden und zu löschen.
Also wenn sich in den Zellen nur Leerzeichen oder und Zeilenumbrüche (nicht Druckbare Zeichen) befinden.

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

Gruß Tino

Clean und Trim 30% schnellen

14.03.2009 14:07:24

Tino

Hallo,

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

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Alle komplett leeren ZEILEN löschen

Forumthread: Alle komplett leeren ZEILEN löschen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Alle komplett leeren ZEILEN löschen

Forumthread: Alle komplett leeren ZEILEN löschen

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread