Macro aan menu koppelen om kleur aan kolomkop toe te voegen bij filter

[Alsdan]

Hoi,

ik werk vaak met (grote) tabellen en gebruik veel het autofilter. Ik heb een tijdje geleden een macro gevonden waarmee je makkelijk kan zien op welke kolommen je een filter aan hebt staan. Het werkt via onderstaande code en daarnaast moet je een functie op je werksheet hebben die bij elke wijziging een berekening uitvoert, bijvoorbeeld een SUBTOTAAL() functie.

Private Sub Worksheet_Calculate()

If ActiveSheet.AutoFilterMode = True Then

    Call Kleur_Actief_Filter

End If

End Sub


Public Sub Kleur_Actief_Filter()

Dim flt As Filter
Dim cCol As Integer
Dim lRow As Long
cCol = 0
lRow = ActiveSheet.AutoFilter.Range.Row
Application.EnableEvents = False

For Each flt In ActiveSheet.AutoFilter.Filters
cCol = cCol + 1

If flt.On = True Then

With Cells(lRow, cCol)
    .Interior.Color = RGB(255, 153, 0)
    .Font.ColorIndex = 1
End With

Else

With Cells(lRow, cCol)
   .Interior.Color = RGB(153, 204, 255)
   .Font.ColorIndex = 1
End With

End If

Next flt

Application.EnableEvents = True

Cells(1, 1).Select

End Sub

Wat ik graag zou willen is dat ik in een nieuw bestand met één druk op de knop (via een nieuw aangemaakt menu-item) deze code kan gebruiken in een nieuwe sheet (in plaats van telkens de code te moeten opvissen uit een Word bestand). Om het nog eenvoudiger te maken zou het mooi zijn als ook in een cel (ergens ver weg gestopt) een subtotaal() functie wordt gezet zodat er helemaal geen extra handelingen meer nodig zijn. Ik krijg dit echter niet voor elkaar. Niet op de directe manier via aanmaken van xlam bestand en niet via een indirecte manier waarbij ik probeerde met een macro gewoon heel de macro tekst in het nieuwe bestand te laten kopiëren (gewoon in de sheet-module). Bij de directe manier krijgen wel de kolomkoppen de "startkleur", maar wijzigt de kleur niet als ik een filter op een kolom zet, dus het lijkt erop dat de macro niet getriggerd wordt. Kan iemand me uitleggen hoe ik dit werkend kan krijgen?

 

[Elsendoorn2134]

Alsdan,

Als je een macro opslaat in een "Persoonlijk macrowerkmap" zal deze altijd binnen Excel beschikbaar zijn.
Tenzij je deze macro's wil delen met anderen is dit een goede optie om bovenstaande macro's altijd beschikbaar te hebben.
De knop om deze macro te starten bestaat al, dit is de F9 toets waarmee je handmatig herberekenen opstart.

Veel Succes.

 

[Alsdan]

Elsendoorn, dank voor je reactie! Maar dit lijkt niet goed te werken. Als ik de macro op sla in de Persoonlijke macrowerkmap en de macro activeer en daarna een filter aan zet dan wordt de kolomkop niet gekleurd. Pas als ik de macro na het filteren nog een keer activeer via Ontwikkelaars - Macro's - Uitvoeren werkt het pas, maar dat betekent dus dat ik na elke filter-actie de macro opnieuw moet activeren en dat is niet echt handig. Het gaat dus mis bij het activeren van de macro via de Worksheet_calculate event.

Ik vermoed dat hetzelfde probleem optreedt als ik de macro als knop toevoeg aan de knoppenbalk, dus de beste oplossing lijkt een macro te maken die ik aan het Excel-menu toevoeg die de code uit een bestandje ophaalt en deze in de "sheet-module" plakt (heet dat zo?, ik bedoel de code van bijvoorbeeld Blad1 (Blad1) ). Kan iemand me (op gang) helpen met een dergelijke macro of een andere/betere oplossing aandragen?

 

[VenA]

Ik zie de noodzaak van het werken met kleurtjes niet in. Als je een bestand met veel kolommen opent en er staan filters op dan kan het handig zijn om even op te vragen waar de filters staan. Als je aan het werk bent in zo'n bestand geeft het in mijn optiek geen enkele meerwaarde om de kolomkoppen te kleuren.

Zelf heb ik zoiets als invoegtoepassing gemaakt. Met daaraan een sneltoets gekoppeld. Dit geeft direct een antwoord waar de filters aan staan, zonder dat ik eerst hoef te zoeken naar kolomkoppen met een afwijkende kleur.

Sub VenA()
If ActiveSheet.AutoFilterMode Then
    Dim c00 As String, t As Integer
    For Each flt In ActiveSheet.AutoFilter.Filters
        If flt.On Then c00 = c00 & Cells(flt.Parent.Range.Row, flt.Parent.Range.Column + t).Address & " "
        t = t + 1
    Next flt
    If c00 <> "" Then MsgBox c00
End If
End Sub

 

[alphamax]

Zie http://stackoverflow.com/questions/...change-in-excel-but-from-my-personal-workbook

 

[Alsdan]

@VenA: nut en noodzaak van een macro is nogal persoonlijk. Hoewel ik jouw macro zeker interessant vind (en meteen heb opgeslagen in mijn macro database, dus dank daarvoor!) voldoet het niet aan mijn wensen. Ik vind het namelijk wel enorm handig om m.b.v. gekleurde kolomkoppen in één oogopslag te zien op welke kolommen een filter aan staat. En ik heb de macro met een aantal collega's gedeeld en die gebruiken 'm ook zeer vaak.

@alphamax: bedankt voor de link, ziet er als een interessante optie uit! Al moet ik toegeven dat ik niet goed snap hoe het werkt (ben een redelijke VBA beginner). Ga er mee stoeien en kijken of ik het kan begrijpen (altijd gevaarlijk als je macro's gebruikt die je niet begrijpt), dus ik kom er nog op terug.

 

[alphamax]

Maak in PERSONAL.XLSB een klassemodule aan genaamd "CAppEventHandler"

Je kan de .cls bestand "importeren" in de modules met dezelfde naam als de bestandsnaam
Of
Je kan mijn PERSONAL_alphamax.XLSB openen en de modules en code nabouwen in jouw PERSONAL.XLSB

Er is ook een testbestandje, de kleuren van de kolomkoppen worden pas bijgewerkt nadat je een andere cel selecteert
Het niet niet mogelijk dit bij te werken nadat je op de filterjes geklikt hebt.

De code werkt ook als de filter niet in A1 begint.

P.S. ik werk soms ook met grote bestanden en gebruik dan een combinatie van filters om op systematische wijze een groter aantal combinaties te doorlopen en hiermee de laatste kolom handmatig met gegevens te vullen

 

[HSV]

Alle codes voor de .xlam.

In de klassemodule; genaamd Klasse1.

Private WithEvents oApp As Excel.Application
 
Property Set XL(Application As Excel.Application)
Set oApp = Application
End Property
Property Get XL() As Excel.Application
    Set XL = oApp
End Property


Private Sub oApp_SheetCalculate(ByVal Sh As Object)
 Application.EnableEvents = False
   Kleur_Actief_Filter
 Application.EnableEvents = True
End Sub

In Thisworkbook.

Option Explicit

Private Sub Workbook_Open()
    Set AnyWorkbook = New Klasse1
    Set AnyWorkbook.XL = Excel.Application
End Sub

In een standaard module.

Global AnyWorkbook As Klasse1

Sub Kleur_Actief_Filter()
Dim Wb As Workbook
Dim c As Range
Dim flt As Filter
Dim cCol As Long
  Set Wb = ActiveWorkbook
    If Wb.ActiveSheet.AutoFilterMode Then


For Each flt In Wb.ActiveSheet.AutoFilter.Filters
     Set c = Wb.ActiveSheet.AutoFilter.Range
     cCol = cCol + 1
     Cells(c.Row, cCol).Interior.Color = IIf(flt.On, RGB(255, 153, 0), RGB(153, 204, 255))
Next flt
  
End If
End Sub

In het werkblad waar de filters staan om te herberekenen.

=subtotaal(3;a2:c10)

De cel worden direct na gebruik van het filter gekleurd.

 

[Alsdan]

HSV en alphamax, dank voor jullie hulp! De invoegtoepassing van HSV is net wat praktischer, dus die ga ik gebruiken. Zolang je het bereik van de subtotaal binnen de tabel laat vallen werkt het prima! Ik had eerst een bereik gekozen buiten de tabel, maar dan herberekent Excel de cel blijkbaar niet.