|
Option Explicit
Public Sub Initialize_DeleteBlankRows()
Dim lngCount As Long
Dim strSelAdr As String
Dim strCellAdr As String
Dim strMsgTxt As String
Dim blnRows() As Boolean
Dim objRng As Range
Dim objCell As Range
Dim objSh As Object
Dim xlCalcMode As XlCalculation
If Check_Exit(Selection) Then Exit Sub
On Error GoTo err_DeleteBlankRows
strSelAdr = Selection.Address(0, 0, xlA1, 0)
xlCalcMode = Application.Calculation
Call Enable_ScreenUpdate(False, xlCalculationManual)
For Each objSh In ActiveWindow.SelectedSheets
If TypeOf objSh Is Worksheet Then
Set objRng = objSh.Range(strSelAdr) _
.SpecialCells(xlCellTypeVisible)
Set objRng = Application.Intersect(objSh.UsedRange, objRng)
If Not objRng Is Nothing Then
blnRows = Get_RowsIndex(objRng)
Set objCell = objRng.Find("*", , xlValues, xlPart)
If Not objCell Is Nothing Then
strCellAdr = objCell.Address
Do
If objCell.Value <> 0 Then
blnRows(objCell.Row) = False
End If
Set objCell = objRng.FindNext(objCell)
Loop Until objCell.Address = strCellAdr
End If
Call Delete_Rows(objSh, blnRows, lngCount)
End If
End If
Next objSh
Call Enable_ScreenUpdate(True, xlCalcMode)
strMsgTxt = "Es wurden " & _
Replace(Format(lngCount, "#,##0 "), "0 ", "keine ") & _
"Zeilen gelöscht!"
MsgBox strMsgTxt, vbExclamation, "Leere Zeilen"
Exit Sub
err_DeleteBlankRows:
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr & vbCr & _
"Quelle" & vbTab & Err.Source & vbCr & _
"Fehler" & vbTab & Err.Description, vbCritical, _
"Fehler " & Err.Number
End Sub
Private Function Get_RowsIndex(ByRef rRng As Range) As Boolean()
Dim i As Long
Dim j As Long
Dim lngAreas() As Long
Dim blnRows() As Boolean
ReDim lngAreas(rRng.Areas.Count, 1) As Long
lngAreas(0, 0) = rRng.Worksheet.Rows.Count
lngAreas(0, 1) = 1
For i = 1 To rRng.Areas.Count
With rRng.Areas(i)
lngAreas(i, 0) = .Cells(1, 1).Row
If lngAreas(0, 0) > lngAreas(i, 0) Then
lngAreas(0, 0) = lngAreas(i, 0)
End If
lngAreas(i, 1) = .Cells(.Rows.Count, 1).Row
If lngAreas(0, 1) < lngAreas(i, 1) Then
lngAreas(0, 1) = lngAreas(i, 1)
End If
End With
Next i
ReDim blnRows(lngAreas(0, 0) - 1 To lngAreas(0, 1)) As Boolean
For i = 1 To UBound(lngAreas, 1)
For j = lngAreas(i, 0) To lngAreas(i, 1)
blnRows(j) = True
Next j
Next i
Get_RowsIndex = blnRows
End Function
Private Sub Delete_Rows(ByRef rWks As Worksheet, ByRef rbRows() _
As Boolean, ByRef rlCount As Long)
Dim i As Long
Dim j As Long
For i = UBound(rbRows) To (LBound(rbRows) + 1) Step -1
If rbRows(i) Then
If rbRows(i - 1) Then
j = j + 1
Else
rWks.Range(rWks.Rows(i), rWks.Rows(i + j)).Delete
rlCount = rlCount + j + 1
j = 0
End If
End If
Next i
End Sub
Private Function Check_Exit(ByRef rSelection As Object) As Boolean
Const s_TITLE As String = "Leere Zeilen löschen?"
Const s_TEXT As String = _
"Leere Zeilen der aktuellen Selektion wirklich löschen?"
Const i_OPTION As Integer = _
vbQuestion + vbYesNo + vbDefaultButton2
If Not TypeOf rSelection Is Range Then
Check_Exit = True
ElseIf Not rSelection.Cells.Count > 1 Then
Check_Exit = True
ElseIf MsgBox(s_TEXT, i_OPTION, s_TITLE) <> vbYes Then
Check_Exit = True
End If
End Function
Private Sub Enable_ScreenUpdate(ByVal vbEnable, _
ByVal vCalcMode As XlCalculation)
Application.Calculation = vCalcMode
Application.EnableEvents = vbEnable
Application.ScreenUpdating = vbEnable
End Sub
|
|