AW: Zeile mit weniger als zwei Einträgen löschen
04.09.2013 14:37:25
fcs
Hallo Tim,
hier ein entsprechendes Makro, das die Zeilen gemäß Kriterien ausblendet.
Zum Löschen muss du nur die bereits vorhandene Zeile aktivieren und das Ausblenden deaktivieren.
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, lngSpalte As Long, StatusCalc As Long
Dim intAnzahlMax As Integer
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 = 12
lngSpalte_1 = 5
Set wks = ActiveSheet
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wks
'Alles einblenden
.Rows.Hidden = False
.Columns.Hidden = False
intAnzahlMax = .Range("N3").Value
'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
'Letzte Spalte
Set rngBereich = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchOrder:=xlByColumns, searchdirection:=xlPrevious)
lngSpalte_L = rngBereich.Column
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 Not Application.WorksheetFunction.CountA(rngBereich) > intAnzahlMax 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
' rngKriterien.EntireRow.Delete Shift:=xlShiftUp 'Zeilen löschen
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