Cellen verbergen op basis van voorwaarde

[Svginkel90]

Beste lezers,

Graag wil ik de volledige kolom verbergen zodra de cellen voldoen aan de voorwaarde. De voorwaarde moet zijn Datum van sheet (b2) > C6. Bereik moet zijn c6 tot bc6.
Graag ook een knop dat ik alles weer zichtbaar kan maken.
Bijgevoegd een voorbeeld.
Hoor graag van jullie.

Mvg,

StevenBekijk bijlage testbestand 7-3-2013.xlsx

 

[Cobbe]

Is dit de bedoeling?

 

[Svginkel90]

Beste Cobbe,

Dank voor jouw bestand!
Het werkt, echter dien ik this Workbook handmatig uit te voeren om de cellen te verbergen. Kan dit doormiddel van changing cell B2?

 

[Cobbe]

Als je dat wil doen wij dat .

Zet deze code achter je werkblad:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Cells(2, 2)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
  Columns.ColumnWidth = 12.5
 For Each cl In Range("C6:BC6")
    If Format(Month(Range("B2")), "00") > Format(Month(cl), "00") Then
      Columns(cl.Column).ColumnWidth = 0
    End If
 Next
Application.ScreenUpdating = True
End Sub

 

[Svginkel90]

Lijkt nog niet volledig juist te verlopen. Kolom 4-3-2013 is nu niet verborgen...

Alvast bedankt Cobbe. Ik leer van je.

 

[Svginkel90]

Lijkt nu wel te werken. Macro is nu:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Cells(2, 2)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Columns.ColumnWidth = 12.5
For Each cl In Range("C6:BC6")
If Range("B2") > cl Then
Columns(cl.Column).ColumnWidth = 0
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Svginkel90]

Beste,

Als ik dit trucje ook voor het tweede blad wil, kan ik mijn changing cell dan ook op het eerste blad laten staan? Bij een verwijzing naar blad 1 B2 op blad 2 wordt de macro niet automatisch uitgevoerd bij een change...

 

[Cobbe]

Haal de oude code weg uit het werkblad en zet deze in ThisWorkbook:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.ScreenUpdating = False
  ActiveSheet.Columns.ColumnWidth = 12.5
 For Each cl In ActiveSheet.Range("C6:BC6")
    If ActiveSheet.Range("B2") > cl Then
      ActiveSheet.Columns(cl.Column).ColumnWidth = 0
    End If
 Next
Application.ScreenUpdating = True
End Sub

 

[Warme bakkertje]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Cells(2, 2)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Sh.Columns.ColumnWidth = 12.5
For Each cl In Sh.Range("C6:BC6")
If Sh.Range("B2") > cl Then
Sh.Columns(cl.Column).ColumnWidth = 0
End If
Next
Application.ScreenUpdating = True
End Sub

Zet bovenstaande in ThisWorkbook. Dan geldt dit voor elk werkblad in je workbook.

 

[Svginkel90]

Dank voor jullie antwoorden. Leer ik veel van!.
Echter is niet ieder blad gelijk in Range. Per tabblad is dit verschillend. Kan ik de range (tabblad 2 bijvoorbeeld ("F4:FF4") in tabblad 3 bijvoorbeeld ("D6:FH6") enz.) dit gemakkelijk aanpassen per tabblad?

 

[Cobbe]

Leer dan maar eens eerst om even over uw vraag na te denken alvorens ze te stellen.

Je wijzigt elke post de spelregels.

 

[Svginkel90]

Excuses. Ik wist niet dat dit via ThisWorkbook ging lopen, oftewel 1 standaard voor alle tabbladen. Ging ervan uit dat dit ook weer per tabblad liep zoals voorheen.

 

[Cobbe]

Haal dan weer maar eens de code weg uit ThisWorkbook en zet in elk blad apart deze code:

Private Sub Worksheet_Activate()
 Application.ScreenUpdating = False
  Columns.ColumnWidth = 12.5
    [B][/B][COLOR="#FF0000"]For Each cl In Range("C6:BC6")[/COLOR]
     If Sheets(1).Range("B2") > cl Then
      Columns(cl.Column).ColumnWidth = 0
     End If
    Next
 Application.ScreenUpdating = True
End Sub

De rode regel dien je aan te passen aan de bereiken van elk blad.

 

[Svginkel90]

Werkt fantastisch. Dit is het geworden:

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Columns.EntireColumn.AutoFit
For Each cl In Range("F4:FF4")
If Sheets("Blad1").Range("B2") > cl Then
Columns(cl.Column).ColumnWidth = 0
End If
Next
Application.ScreenUpdating = True
End Sub

Dank voor jullie hulp!!