Rapportfilter draaitabel automatisch selecteren

[LindaVelde]

Beste allemaal,

Wij zitten momenteel "in-between" facturatiesystemen waardoor ik zelf wat heb gebouwd met Excel.
Ik ben best ver gekomen (zonder ICT achtergrond) maar ik zou graag nog 1 ding willen aanpassen:
Ik wil graag dat het Rapportfilter van de draaitabel op de tabbladen Specificatie VSXXXX automatisch worden beperkt tot de inhoud van een bepaalde cel (C1 op hetzelfde tabblad).

Wat heb ik gemaakt is:

• Tabblad: Totaal verr. excl. niet decl.: Dit is het verzamelblad van alle data welke ik invoer vanuit een ander programma.
• Tabblad: Contracttype: stamgegevens van de bedrijven
• Tabblad: Tarieven: stamblad van de tarieven
• Tabblad: Facturen: draaitabel van de tabel op de eerste tabblad met de totalen per bedrijf
• Tabblad: Factuurnummers: tabel voor het toewijzen van factuurnummers
• Tabblad: XXXX, dit is het voorblad van een factuur. Door het factuurnummer in het tabblad in te voeren worden alle gegevens op het tabblad zelf juist ingevuld.
• Tabblad: Specificatie VSXXXX, dit is de specificatie per factuur.Door het factuurnummer in het tabblad in te voeren worden de basisgegevens op het tabblad zelf juist ingevuld. Daar staat ook een draaitabel met de gegevens van het eerste tabblad. Het rapportfilter is de bedrijfsnaam. Hier wil ik graag dat het rapportfilter zich automatisch aanpast naar de inhoud in cel C1

Ik heb wat zitten googlen en ik kwam wel een aantal macro's tegen maar weet niet hoe ik die moet toepassen.
Mijn kennis van VBA is heel beperkt.

En hoe stel ik het zo in dat ik het laatste tabblad kan kopiëren en verplaatsen zodat de macro gewoon blijft functioneren op het nieuwe tabblad?

Bijgesloten mijn test bestand.

Alvast bedankt voor jullie hulp!

EDIT: Ik heb een nieuw aangepast bestand bijgesloten
Bekijk bijlage nieuw testbestand fact feb 2016.xlsm

 

[LindaVelde]

Ik ben al weer een stukje verder door anders te zoeken op dit Forum: http://www.helpmij.nl/forum/showthread.php/829803-Macro-Draaitabel-filter-met-copy-paste-in-macro

Ik heb de volgende code die werkt!

(Hoera voor het betere jatwerk)

Alleen heb ik de macro gekoppeld aan een knop omdat ik hem anders niet werkzaam kreeg.

Public Sub selectie()
Dim CurItem As Object
Dim sWaarde As String

sWaarde = Sheets("Specificatie VS2500").Range("C1")

With Sheets("Specificatie VS2500").PivotTables("Draaitabel3").PivotFields("Bedrijfsnaam:")
    .PivotItems(.PivotItems.Count).Visible = True   'Omdat er altijd minimaal 1 aan moet staan set de laatste aan.
    For Each CurItem In .PivotItems                 'Doorloop alle gegevens
        If CurItem.Name = sWaarde Then              'Als gelijk aan cel L2 dan tonen
            CurItem.Visible = True
        Else                                        'Anders niet tonen
            CurItem.Visible = False
        End If
    Next
End With

End Sub

Maar hoe hernoem ik het blad Sheets("Specificatie VS2500") zodat het automatisch het actieve blad pakt?
Dan kan ik het blad kopiëren.

En hoe maak ik het zo dat ik de macro direct werkt als cel C1 aangepast wordt ipv van een knop?

 

[VenA]

Ik zou eerst het bestand maar eens ontdoen van vertrouwelijke informatie. Draai deze eens vanaf tab 'Specificatie VS2500' en je zal zien hoeveel sporen een draaitabel achter laat.

Sub VenA()
Application.ScreenUpdating = False
With ActiveSheet
    For Each pt In .PivotTables
        For Each it In pt.PivotFields("Bedrijfsnaam:").PivotItems
            MsgBox it.Value
            If it.Value <> .[c1] Then it.Visible = False Else it.Visible = True
        Next it
    Next pt
End With
End Sub

Dus sloop de vertrouwelijke info er eerst uit. Sla het bestand op als .xlsb dan mag het groter zijn dan 100 Kb en verwijder het bestand in de OP.

 

[LindaVelde]

Bedankt VenA!

Geen idee dat er zoveel informatie nog te herleiden is :shocked:

Hoe kun je dat zien?

Ik dacht dat ik het al aardig had verborgen door alles te hernoemen.

Ik ga er mee aan de slag

 

[VenA]

Als je rechtsklikt in een draaitabel dan kan je kiezen voor 'Opties voor draaitabel' op de laatste tab moet je dan wat wijzigen. Brongegevens moet je uitzetten en aantal items moet je op geen zetten. Dit maakt het bestand kleiner en niemand kan meer bij de oorspronkelijke gegevens:d

 

[HSV]

Ik zie nergens een bestand, dus maar op de gok.
Je krijgt inderdaad een foutmelding als de waarde niet wordt gevonden en toch alle items op visible = false te zetten.

Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim x As Boolean
If Target.Address(0, 0) = "c1" Then
    With me.PivotTables("Draaitabel3").PivotFields("Bedrijfsnaam:")
 .ClearAllFilters
     For i = 1 To .PivotItems.Count
        With .PivotItems(i)
           If .Value =target.value Then
                 .Visible = True
                 x = True
            ElseIf i = .Parent.PivotItems.Count And x = False Then
                       .Parent.ClearAllFilters
                    MsgBox "Waarde niet gevonden!"
                     Application.EnableEvents = True
                    Exit Sub
            Else
                .Visible = False
            End If
        End With
      Next i
  End With
End If
Application.EnableEvents = True
End Sub

 

[LindaVelde]

Beste allemaal,

Excuus voor de late reactie.
Ik was helaas niet instaat eerder te reageren.

Ik heb om er zeker van te zijn het gehele bestand zo ver als mogelijk opnieuw gemaakt zonder oude data te gebruiken.

Volgens mij kun je nu niet meer bij oude data van daadwerkelijke klanten.

Ik krijg het VBA scriptje niet aan de praat.

Kan iemand mij daarbij verder helpen?
LEt wel. Macro's kan ik wel maken maar ik weet niet zo goed hoe ik dit toe voeg zodat het automatisch werkt.

 

[HSV]

Hallo Linda,

De code hoort niet in een standaard module maar in de bladmodule van toepassing.
Ik ga er even handmatig vanuit door middel van een wijziging in cel D1 omdat er een formule staat in cel C1.
De code is dus gebaseerd op handmatig wijzigen.
Wil je dit dmv die formule werkt het misschien in de calculate-event omgeving.
Ik heb de code geplaatst in werkbladmodule 'VS2501'.

 

[LindaVelde]

Super bedankt HSV!

Alleen nu moet ik nog steeds een handeling per gekopieerde sheet uitvoeren.

Of bestaat er een macro waarmee ik bijv. voor alle sheets cel C1 de waarde kopieer in cel D1?
Dan is het helemaal opgelost.

Nogmaals bedankt!

 

[VenA]

Je kan de code met een paar kleine aanpassingen is de module van ThisWorbook zetten. In het voorbeeldje werkt het de naam van het blad begint met "Specificatie".

 

[HSV]

Dan zou je zoiets kunnen inzetten in de module van Thisworkbook.
De array kun je uitbreiden met je bladnamen.

Misschien moet je het een en ander nog wijzigen maar daar heb ik geen gegevens over (er staat nl. maar een draaitabel in je bestand).

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim x As Boolean
For Each Sh In Array("specificatie vs2501")
    With Sh.PivotTables(1).PivotFields("Bedrijfsnaam:")
 .ClearAllFilters
     For i = 1 To .PivotItems.Count
        With .PivotItems(i)
           If .Value = Target.Value Then
                 .Visible = True
                 x = True
            ElseIf i = .Parent.PivotItems.Count And x = False Then
                       .Parent.ClearAllFilters
                    MsgBox "Waarde niet gevonden!"
                     Application.EnableEvents = True
                    Exit Sub
            Else
                .Visible = False
            End If
        End With
      Next i
  End With
Next Sh
Application.EnableEvents = True
End Sub

 

[LindaVelde]

De code van VenA werkt heel goed.
Ook in mijn bestand.

Alleen crasht mijn excel er op

Het is ook wel heel erg veel data wat mijn eenvoudig computertje allemaal moet berekenen.
Ik ga het eerst thuis eens op mijn eigen PC (welke veel beter is) proberen of het daar ook crasht.


Super bedankt allemaal!

 

[HSV]

Ik weet het antwoord al; zie #6.

Edit: ik zie nu pas dat @VenA een minuut eerder reageerde dan mij.

 

[LindaVelde]

Bij nader inzien werkt het toch niet helemaal.

Wat bedoel je precies HSV met #6

 

[HSV]

Edit van 10 febr. 12:51 uur.

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Application.ScreenUpdating = False
Application.EnableEvents = False
If LCase(Sh.Name) = "specificatie vs2501" Or Sh.Name = "2500" Then
 On Error Resume Next
    With Sh.PivotTables(1).PivotFields("Bedrijfsnaam:")
      .ClearAllFilters
      .CurrentPage = sh.[c1].Value
     If Err.Number <> 0 Then MsgBox "Waarde van blad " & Sh.Name & " niet gevonden!"
      On Error GoTo 0
   End With
 End If
Application.EnableEvents = True
End Sub