Über Filter werden die gesuchten Werte einer grossen Tabelle eingegrenzt.
Wie kann ich nun die Spalten automatisch ausblenden deren Inhalt in allen SICHTBAREN Zellen leer ist.
Wie ermittle ich das? Makro gesucht!
Vielen Dank für Eure Hilfe
Gruss Urs
Sub Test_Leer_Spalten_Aus()
Dim Bereich As Range, booIsLeer As Boolean
Dim tmpRng As Range, rngZellen As Range
Dim oSh As Worksheet
'Tabelle anpassen
With Tabelle1
Set Bereich = .UsedRange
With Application.WorksheetFunction
For Each Bereich In Bereich.Columns
'Bereich.Cells(2, 1) zwei ist ohne Überschrift
Set rngZellen = Range(Bereich.Cells(2, 1), Bereich.Cells(Bereich.Rows.Count, 1))
booIsLeer = .CountIf(rngZellen, "") = rngZellen.Cells.Count
If booIsLeer Then
If Not tmpRng Is Nothing Then
Set tmpRng = Union(rngZellen, tmpRng)
Else
Set tmpRng = rngZellen
End If
End If
Next Bereich
End With
If Not tmpRng Is Nothing Then
tmpRng.EntireColumn.Hidden = True
End If
End With
End Sub
Gruß TinoOption Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "^%b"
End Sub
Private Sub Workbook_Open()
Application.OnKey "^%b", "Test_Leer_Spalten_Aus"
End Sub
kommt als Code in Modul1
Option Explicit
Function ZaehleSichtbareLeere(ByVal Bereich As Range, MaxOG As Long) As Boolean
Dim LCounter As Long
Dim LAnzahlZellen As Long
On Error Resume Next
Set Bereich = Bereich.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Bereich Is Nothing Then Exit Function
If Bereich.Cells.Count = MaxOG Then Exit Function
LAnzahlZellen = Bereich.Cells.Count
With Application.WorksheetFunction
For Each Bereich In Bereich.Areas
LCounter = LCounter + .CountIf(Bereich, "")
Next Bereich
End With
ZaehleSichtbareLeere = LCounter = (LAnzahlZellen - MaxOG)
End Function
Sub Test_Leer_Spalten_Aus()
Dim Bereich As Range, booIsLeer As Boolean
Dim tmpRng As Range
Dim oSh As Worksheet
Static booVisible As Boolean
With ActiveWorkbook.ActiveSheet
If Not booVisible Then
Set Bereich = .UsedRange
For Each Bereich In Bereich.Columns
If ZaehleSichtbareLeere(Bereich, 1) Then
If Not tmpRng Is Nothing Then
Set tmpRng = Union(Bereich, tmpRng)
Else
Set tmpRng = Bereich
End If
End If
Next Bereich
If Not tmpRng Is Nothing Then
tmpRng.EntireColumn.Hidden = True
booVisible = True
End If
Else
.UsedRange.EntireColumn.Hidden = False
booVisible = False
End If
End With
End Sub
Gruß Tino