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