Grafiektitel automatisch aanpassen a.h.v.gekozen filter(s)

[Soundslave9]

Hoi,

In bijgaand bestand een klein voorbeeld.

Als het mogelijk is wil ik graag de grafiektitel (deels) ophalen uit de geselecteerde filters.

Bijv. als ik bij kolom soort Auto selecteer in de filter, dat dit dan ook in de grafiektitel komt.
Hoeft niet rechtstreeks, maar bijv. eerst in een cel waarnaar ik verwijs in de titel.

Dan kan ik nl. nog wat verder klooien, bijv. als de gekozen filters in kolom soort Auto en Trein zijn, dan een als-functie waar dan "Landvoertuigen" o.i.d. uitkomt. Dat zal dan in de grafiektitel moeten komen samen met bijv. 1e Kwartaal.

Dus eigenlijk hoef ik voorlopig alleen te weten of bovenstaande, (titel(s)) ophalen uit filtercategorie van de kolom mogelijk is. En zo ja, hoe
Liefst met excel-functie, maar mag ook evt. middels VBA.

@ mod: Zal ik deze vraag dan ook in VBA-sectie posten? Of doen jullie dat dan?

Nou hoop dat het mogelijk is ben al hele middag aan t zoeken geweest, vind het niet.

Bij voorbaat dank

Een fijne avond

 

[JEC.]

Bvb

 

[Soundslave9]

Dank je JVeer

Ik zal er vandaag iets mee proberen. Waarschijnlijk heb ik er nog wat vragen over

 

[Soundslave9]

Werkt oké maar...

Het lukt me nog niet om de titel/cel te resetten als de filter uit staat.

In bijlage wat ik eraan geprobeerd heb.

Tevens zou ik willen dat hij het de items uit het filter telt en dat ik ook deze gegevens in de titel kan zetten.
Heb ook al gelezen dat datums ietwat anders benaderd moeten worden.

Toch lastiger dan ik dacht.

 

[Haije]

met draaitabel en -grafiek

is dit iets?

 

[Soundslave9]

Hoi Haije,

Bedankt voor de moeite. Helaas kun je vanuit een draaitabel geen Pareto-grafiek maken, tenminste niet naar mijn weten.

 

[JEC.]

Zet deze eens achter je werkblad 1

Private Sub Worksheet_Calculate()
 Set dict = CreateObject("scripting.dictionary")
 Set LO = Sheets(1).ListObjects(1)
 ar = LO.DataBodyRange
    
    If Not LO.AutoFilter.FilterMode Then
        Cells(1, 15) = "All" & " : " & LO.TotalsRowRange(10).Value
    Else
       For i = 1 To LO.ListRows.Count
          If Not LO.DataBodyRange(i, 2).EntireRow.Hidden Then
             c00 = dict.Item(ar(i, 2))
          End If
       Next
       Cells(1, 15) = Join(dict.keys, " en ") & " : " & LO.TotalsRowRange(10).Value
    End If
End Sub

 

[huijb]

Verplaatst naar VBA op verzoek.

 

[Soundslave9]

Het werkt heel mooi in het voorbeeldbestand!

Echter krijg ik het niet goed geimplementeerd in het beoogde sheet waarvoor het bedoeld is.

Ik heb de originele code van JVeer als volgt aangepast:

Private Sub Worksheet_Calculate()

 Set dict = CreateObject("scripting.dictionary")
 Set LO = Sheets([B]6[/B]).ListObjects([B]13[/B])
 ar = LO.DataBodyRange
    
    If Not LO.AutoFilter.FilterMode Then
        Cells(1, [B]2[/B]) = "All"
    Else
       For i = 1 To LO.ListRows.Count
          If Not LO.DataBodyRange(i, [B]5[/B]).EntireRow.Hidden Then
             c00 = dict.Item(ar(i, [B]5[/B]))
          End If
       Next
       Cells(1, [B]2[/B]) = Join(dict.keys, " en ") & " : " & LO.TotalsRowRange(10).value
    End If

End Sub

Het gaat om blad6(Pareto) (althans zo staat het benoemd in het objectenoverzicht in VBA-venster.
Beoogde tabel heet Tabel13, kolomnummer is 5.

Wellicht moet ik nog iets aanpassen aan TotalsRowRange(10)?
In het originele bestand wordt de tabel automatisch aangevuld met meerdere rijen en staat er géén totalenrij onderaan de tabel. Die heb ik voor de overzichtelijkheid boven de tabel geplaatst.

De foutmelding die ik krijg:

Fout 9, subscript valt buiten het bereik op regel 2 Set LO = Sheets(6).ListObjects(13)



Morgen verder proberen...

Heb nog wel wat vraagjes als het mag

Fijne avond

 

[JEC.]

Het is niet de 13e tabel van die sheet
Schrijf eens gewoon Tabel13 tussen aanhalingstekens ipv 13

 

[Soundslave9]

Klopt je hebt gelijk, is idd Tabel13 ooit gemaakt in de gehele werkmap.
Maar, in eerdere post vergeten te vermelden, ik had in eerste instantie al alleen blad 6 aangepast en Listobjects op 1 laten staan, maar kreeg toen dezelfde foutmelding.
Toen heb ik jouw suggestie ook al toegepast ("Tabel13")
He nu ook 2 geprobeerd, ik dacht misschien is de gafiek listobject1?

Maar de foutmelding blijft.

Kan ik in VBA venster ergens een overzicht vinden van de listobjects binnen het project?
Ik kan alleen de bladen als objects zien in het overzicht.

Bedankt.

 

[JEC.]

Plaats anders je bestand even
Of probeer nog eens voor de zekerheid je sheetnaam ook uit te schrijven ipv alleen 6. Ook de code achter het juiste blad gezet?

 

[cow18]

Helaas kun je vanuit een draaitabel geen Pareto-grafiek maken, tenminste niet naar mijn weten.

https://www.youtube.com/watch?v=k3js0XnefEU

Daarnaast is er nog iets grappig aan "tabel13", "grafiek7", "draaitabel1" etc, zoals excel die standaard bij creatie noemt.
Die gebruikte namen zijn gevoelig aan je taalinstellingen en ik vermoed dat tot nogtoe iedereen hier een nederlandstalige versie gebruikt heeft.
Op een engelstalige noemt diezelfde tabel wel plots "table13", dus is het wel even handig om die tabel te hernoemen naar iets dat praktisch is voor eigen gebruik bv. "TBL_Voertuigen" en die naam dan te gebruiken in je VBA als sheets(...).listobjects("TBL_Voertuigen") en dan heb je dat taalprobleempje voorkomen en werkt het op alle PC's ongeacht hun taalinstelling.

Ik ben geen fan van het gebruik van het indexnummers in sheets(6) of listobjects(2) ! Er zal maar een grappige gebruiker straks een werkblad of een tabel vroeger toevoegen (niet in geval van tabellen) of verwijderen. Gebruik de codename of de echte naam daar.

 

[HSV]

Of rechtstreeks.

Private Sub Worksheet_Calculate()
Set d = CreateObject("scripting.dictionary")
With Sheets(1).ListObjects(1)
 a = .DataBodyRange
  If Not .AutoFilter.FilterMode Then
        [COLOR=#ff0000]ChartObjects(1).Chart.ChartTitle.Text[/COLOR] = "All" & " : " & .TotalsRowRange(10).Value
     Else
       For i = 1 To .ListRows.Count
         If Not .DataBodyRange.Rows(i).Hidden Then d(a(i, 2)) = ""
       Next
     [COLOR=#ff0000]ChartObjects(1).Chart.ChartTitle.Text [/COLOR]= Join(d.keys, " en ") & " : " & .TotalsRowRange(10).Value
   End If
 End With
End Sub

 

[Soundslave9]

Lange dag gehad...


@ Jveer:

Of probeer nog eens voor de zekerheid je sheetnaam ook uit te schrijven ipv alleen 6. Ook de code achter het juiste blad gezet?

Had ik al geprobeerd.

Wat me verder opviel is dat de fout 9 alleen ontstaat wanneer er naast mijn eigen wekmap nog een andere werkmap geopend is óf geopend wordt. In 2e geval gelijk fout 9 "buiten bereik" getriggerd in worksheet_calculate event van blad6 (Pareto). Dit gebeurt ook wanneer ik in de kolom filter of filter uitzet in het testbestand van JVeer. Dus in beide gevallen foutmelding in mijn eigen bestand in de regel:

Set LO = Worksheets("Pareto").ListObjects("tblPareto")

Is er geen andere map geopend dan dus geen fout 9 maar ontstaat verderop in de code fout 438 "eigenschap of methode niet ondersteund door dit object" in de regel:

Cells(1, 2) = Join(dict.keys, " en ") & " : " & LO.TotalsRowRange(10).value

Kan dit door de waarde (10) komen? Waar staat deze trouwens voor.

Verder ben/moet ik me verder verdiepen in "scripting.dictionary", c00. Zijn nieuw voor mij wel interessant. Lijkt me toch vrij lastig.

@cow18: Bedankt voor de link! En zoals je ziet heb ik de tabel op jouw advies een naam gegeven
@HSV: idd maar lijkt me lastiger (voor mij i.i.g.) mocht ik verder nog wat tekstbewerkingen uitvoeren met de uitkomsten.

In weekend verder kijken, morgen weer drukke dag.

Fijne avond