Filter draaitabel op basis van celwaarde

Murphy88 · 22 okt 2019

Beste allen,

Ik ben in het verleden al vaak goed geholpen hier dus ik doe nog een poging in iets waar ik al een lange tijd niet uitkom.

Vanwege esthetische redenen wil ik in 'dit deel' van mijn dashboard geen slicers gebruiken. Wel wil ik de gebruiker via een dropdown list de mogelijkheid geven om verschillende combinaties te filteren in een draaitabel.
Ik stuur een testbestand mee.

Concreet: ik wil graag via 2 parameters/dropdown lists een selectie kunnen maken in het filter. In het echte model gaat het om bijna 50 mogelijkheden en bestaat het bronbestand uit bijna een miljoen regels, het moet dus nog wel snel/efficiënt kunnen werken.

Code die ik gevonden heb wat werkt op basis van 1 parameter is (deze uitbreiden naar 2, geen idee hoe ik dat in elkaar zet):

Private Sub Worksheet_Change(ByVal Target As Range)

Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
On Error Resume Next
If Intersect(Target, Range("H6:H7")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet1").PivotTables("PivotTable2")
Set xPFile = xPTable.PivotFields("Category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub

Hoop dat iemand hier wat mee kan, ben benieuwd.

Met vriendelijke groet,

Murphy

Murphy88 · 23 okt 2019

Misschien moet ik mijn vraag anders definiëren:

Ik wil dat beide waardes (Testfile, bijlage openingspost), cel O8 + P8 geselecteerd worden in het filter.
De macro die er nu inzit kiest er 1 van de twee, dus volgens mij zijn we dichtbij een oplossing.

VenA · 23 okt 2019

Plaats code svp tussen codetags.

Ik zou wel en slicer gebruiken. Wel even buiten beeld plaatsen als je deze niet wil zien maar is iets makkelijker aan te sturen dan een draaitabelfilter.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("O8:P8")) Is Nothing Then
    With ActiveWorkbook.SlicerCaches("Slicer_Artikel")
      .ClearManualFilter
      For Each it In .SlicerItems
        it.Selected = InStr(Range("O8") & Range("P8"), it.Value)
      Next it
    End With
  End If
End Sub

Murphy88 · 24 okt 2019

VenA zei:
Plaats code svp tussen codetags.

Ik zou wel en slicer gebruiken. Wel even buiten beeld plaatsen als je deze niet wil zien maar is iets makkelijker aan te sturen dan een draaitabelfilter.

Code:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("O8:P8")) Is Nothing Then With ActiveWorkbook.SlicerCaches("Slicer_Artikel") .ClearManualFilter For Each it In .SlicerItems it.Selected = InStr(Range("O8") & Range("P8"), it.Value) Next it End With End If End Sub

cow18 zei:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim xPTable As PivotTable
   Dim xPFile  As PivotField
   Dim xStr    As String
   On Error Resume Next
   If Intersect(Target, Range("O8:P8")) Is Nothing Then Exit Sub
   Application.ScreenUpdating = False
   Set xPTable = Worksheets("Blad1").PivotTables("Productie")
   Set xPFile = xPTable.PivotFields("Artikel")
   xPFile.ClearAllFilters
   xPFile.EnableMultiPageItems = True
   If WorksheetFunction.CountA(Range("O8:P8")) Then                  'niets ingevuld = alles tonen
      For Each it In xPFile.PivotItems
         it.Visible = (it.Name = Range("o8").Value Or it.Name = Range("p8").Value)
      Next
   End If
   Application.ScreenUpdating = True
End Sub

@VenA, @cow18 dank voor de hulp! Beide werken en geven hetzelfde resultaat. Heb nu de code van VenA gebruikt. Wat wel jammer is is dat het best traag werkt. Het lijkt erop dat eerst alle items in de slicer worden geactiveerd en vervolgens worden alle items behalve de waardes ingevuld in cel O8 en P8 weer uitgezet en dat gaat 1 voor 1. Met mijn volledige dataset duurt dat bijna 1 minuut (heb alle processors in gebruik, op een i7).

Kan dat misschien nog anders, sneller? Zou het bijvoorbeeld ook zo kunnen: stel ik verander de waarde in O8, dat hij eerst de oude waarde van O8 uitzet en daarna de nieuwe waarde van O8 aanzet, P8 ongemoeid en visa versa?

jkpieterse · 24 okt 2019

Middels deze code werkt het als het goed is efficienter omdat je alleen de relevante items in en uitschakelt. Bovendien wordt het herhaaldelijk aanroepen van het event voorkomen:

Code:

Option Explicit
Dim NoEvent As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim PTable As PivotTable
    Dim PFld As PivotField
    Dim PI As PivotItem
    Dim Str As String
    Dim Vals As Variant
    Dim Vis As Boolean
    If NoEvent Then Exit Sub
    On Error Resume Next
    If Intersect(Target, Range("O8:P8")) Is Nothing Then Exit Sub
    NoEvent = True
    Vals = Range("O8:P8").Value
    Application.ScreenUpdating = False
    Set PTable = Worksheets("Blad1").PivotTables("Productie")
    Set PFld = PTable.PivotFields("Artikel")
    'Zet laatste item op true, anders kan het zijn dat de code probeert alle items weg te filteren en dat mag niet
    PFld.PivotItems(PFld.PivotItems.Count).Visible = True
    For Each PI In PFld.PivotItems
        Vis = (PI.Name = Vals(1, 1) Or PI.Name = Vals(1, 2))
        If PI.Visible <> Vis Then
            PI.Visible = Vis
        End If
    Next
    Application.ScreenUpdating = True
    NoEvent = False
End Sub

Murphy88 · 24 okt 2019

jkpieterse zei:

Middels deze code werkt het als het goed is efficienter omdat je alleen de relevante items in en uitschakelt. Bovendien wordt het herhaaldelijk aanroepen van het event voorkomen:

Code:

Option Explicit
Dim NoEvent As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim PTable As PivotTable
    Dim PFld As PivotField
    Dim PI As PivotItem
    Dim Str As String
    Dim Vals As Variant
    Dim Vis As Boolean
    If NoEvent Then Exit Sub
    On Error Resume Next
    If Intersect(Target, Range("O8:P8")) Is Nothing Then Exit Sub
    NoEvent = True
    Vals = Range("O8:P8").Value
    Application.ScreenUpdating = False
    Set PTable = Worksheets("Blad1").PivotTables("Productie")
    Set PFld = PTable.PivotFields("Artikel")
    'Zet laatste item op true, anders kan het zijn dat de code probeert alle items weg te filteren en dat mag niet
    PFld.PivotItems(PFld.PivotItems.Count).Visible = True
    For Each PI In PFld.PivotItems
        Vis = (PI.Name = Vals(1, 1) Or PI.Name = Vals(1, 2))
        If PI.Visible <> Vis Then
            PI.Visible = Vis
        End If
    Next
    Application.ScreenUpdating = True
    NoEvent = False
End Sub

Ik heb deze niet werkend, lijkt erop dat er niet zo veel gebeurd. Wat ook zou mogen, daar kan ik ook goed mee leven is dat cel P8 wordt vastgezet, dat deze dus altijd geselecteerd is in het filter en dat alleen O8 de variabele is.
(heb je code in mijn model verwerkt en hij filtert alles weg behalve het laatste item in de lijst)

jkpieterse · 24 okt 2019

Vreemd, in je voorbeeldbestand werkte het bij mij prima?

VenA · 24 okt 2019

Wil je svp niet elk bericht quoten?

Heb je mijn code ook getest met Application.ScreenUpdating = False en eventueel de Events uitzetten.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.EnableEvents = False
  If Not Intersect(Target, Range("O8:P8")) Is Nothing Then
    Application.ScreenUpdating = False
    With ActiveWorkbook.SlicerCaches("Slicer_Artikel")
      .ClearManualFilter
      For Each it In .SlicerItems
        it.Selected = InStr(Range("O8") & Range("P8"), it.Value)
      Next it
    End With
  End If
  Application.EnableEvents = True
End Sub

Murphy88 · 24 okt 2019

ik ga er straks even op m'n gemak opnieuw mee knutselen, ik upload daarna even een nieuw testbestandje (misschien ook wel met wat meer data)

Murphy88 · 24 okt 2019

@17jkpieterse ik heb het werkend met jouw code. Werkt snel en efficiënt! Dank daarvoor. (ik had de target cells onder elkaar staan, zou het daardoor niet gewerkt hebben?)

@VenA het aansturen van een slicer is wel een mooie oplossing, dan kan ik eenvoudig meerdere draaitabellen linken. Ik krijg het alleen niet sneller werkend. Ik heb namelijk een vergelijkbare draaitabel die eigenlijk met dezelfde criteria aangestuurd mag worden, dat wordt even puzzelen hoe ik deze in de code van pieterse kan integreren.

Maar waar ik nu achter kom, de cell die de target cell aanstuurt staat op een ander sheet waardoor de 'verandering' van de cell niet gezien wordt. Kan ik dit eenvoudig fixen?

VenA · 24 okt 2019

Wat hebben we dan aan zo voorbeeldbestand? Cellen staan blijkbaar onder elkaar de draaitabellen staan ergens anders. Staat de brondata ook ergens anders? Maak een realistisch bestand en plaats dat hier.

Murphy88 · 24 okt 2019

Ok, ik heb een 'realistisch' voorbeeldbestand gemaakt.

3 sheets: brondata, draaitabellen, dashboard.

Sheet brondata en draaitabel moet uiteindelijk verborgen en beveiligd worden. Data hoeft niet te worden ververst, dat gebeurt handmatig.
Op sheet dashboard moet via dropdown lists het filter van betreffende draaitabel aangestuurd worden.
Draaitabellen kunnen in het voorbeeld op het filter gelinkt worden (beide hetzelfde filter --> in het voorbeeld "Artikel").

Een slicer zou dus erg mooi zijn maar die werkt dus erg traag.

Ik heb de macro van jkpieterse erin.

HSV · 24 okt 2019

Hoe werkt dit?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address(0, 0) = "K9" Then
  Application.EnableEvents = False
    PivotTables(1).PivotFields("artikel").CurrentPage = target.Value
    PivotTables(2).PivotFields("artikel").CurrentPage = target.Value
  Application.EnableEvents = True
 End If
End Sub

Murphy88 · 25 okt 2019

Ik ben er nu wel bijna, heb hier weer veel van opgestoken. Ik wil eigenlijk deze code dupliceren en ook op een andere cel binnen hetzelfde sheet gebruiken maar dan voor de target cells O125 en P125. Cell O125 en P125 hoort bij een andere draaitabel. Kan iemand me helpen hoe ik dat in onderstaande code verwerk?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim PTable As PivotTable
    Dim PFld As PivotField
    Dim PI As PivotItem
    Dim Str As String
    Dim Vals As Variant
    Dim Vis As Boolean
    If NoEvent Then Exit Sub
    On Error Resume Next
    If Intersect(Target, Range("N124:O124")) Is Nothing Then Exit Sub
    NoEvent = True
    Vals = Range("N124:O124").Value
    Application.ScreenUpdating = False
    Set PTable = Worksheets("draaitabeltest").PivotTables("test")
    Set PFld = PTable.PivotFields("Artikel")
    PFld.PivotItems(PFld.PivotItems.Count).Visible = True
    For Each PI In PFld.PivotItems
        Vis = (PI.Name = Vals(1, 1) Or PI.Name = Vals(1, 2))
        If PI.Visible <> Vis Then
            PI.Visible = Vis
        End If
    Next
    Application.ScreenUpdating = True
    NoEvent = False
End Sub

jkpieterse · 25 okt 2019

Code aangepast en verplaatst naar het Dashboard tabblad.

Murphy88 · 25 okt 2019

Dit is hem! Mijn dank is groot.

Filter draaitabel op basis van celwaarde

Murphy88

Gebruiker

Bijlagen

Murphy88

Gebruiker

VenA

Inventaris

Murphy88

Gebruiker

jkpieterse

Terugkerende gebruiker

Murphy88

Gebruiker

jkpieterse

Terugkerende gebruiker

VenA

Inventaris

Murphy88

Gebruiker

Murphy88

Gebruiker

VenA

Inventaris

Murphy88

Gebruiker

Bijlagen

HSV

Inventaris

Murphy88

Gebruiker

jkpieterse

Terugkerende gebruiker

Bijlagen

Murphy88

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy