AW: Zeilen ausblenden, wenn bestimmter Bereich leer
23.09.2013 14:52:18
fcs
Hallo Tim,
ich hab das andere Makro jetzt auf die neuen Prüfbedingungen umgeschrieben.
Gruß
Franz
'Makro in einem allgemeinen Modul erstellt unter Excel 2010
Sub Zeilen_Ausblenden()
Dim wks As Worksheet, rngBereich As Range, rngKriterien As Range
Dim lngZeile_1 As Long, lngSpalte_1 As Long
Dim lngZeile_L As Long, lngSpalte_L As Long
Dim lngZeile As Long, StatusCalc As Long
StatusCalc = Application.Calculation
If MsgBox("Zeilen gemäß Kriterien ausblenden?", vbQuestion + vbOKCancel, _
"Z E I L E N A U S B L E N D E N") = vbCancel Then GoTo Beenden
On Error GoTo Fehler
lngZeile_1 = 2
lngSpalte_1 = 45
lngSpalte_L = 54
Set wks = ActiveSheet
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wks
'Alle Zeilem einblenden
.Rows.Hidden = False
'letzte Zeile
Set rngBereich = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchOrder:=xlByRows, searchdirection:=xlPrevious)
If rngBereich Is Nothing Then
MsgBox "Keine Daten im Tabellenblatt", vbInformation + vbOKOnly, _
"Makro: Zeilen_Ausblenden"
GoTo Beenden
End If
lngZeile_L = rngBereich.Row
For lngZeile = lngZeile_L To lngZeile_1 Step -1
'relevanter Bereich
Set rngBereich = .Range(.Cells(lngZeile, lngSpalte_1), _
.Cells(lngZeile, lngSpalte_L))
'Prüfen der Anzahl Werte im relevanten Bereich
If Application.WorksheetFunction.CountA(rngBereich) = 0 Then
If rngKriterien Is Nothing Then
Set rngKriterien = .Cells(lngZeile, 1)
Else
Set rngKriterien = Application.Union(rngKriterien, .Cells(lngZeile, 1))
End If
End If
Next
If Not rngKriterien Is Nothing Then
rngKriterien.EntireRow.Hidden = True 'Zeilen ausblenden
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbCritical + vbOKOnly, _
"Fehler - Makro Zeilen_Ausblenden"
End Select
End With
Beenden:
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
Set wks = Nothing: Set rngBereich = Nothing: Set rngKriterien = Nothing
End Sub