sandra1978
Gebruiker
- Lid geworden
- 21 feb 2011
- Berichten
- 64
Hallo,
Ik heb een draaitabel (tabblad "per persoon"), waarbij ik van elk sliceritem "lesgever naam" een pdf wil opslaan. De code is hoofdzakelijk gebaseerd op wat ik op 't net gevonden heb. Er wordt effectief iets opgeslagen, maar:
- lay-out ziet er anders uit
- ik krijg een som ipv een gemiddelde te zien
- een absoluut getal ipv een percentage
Ik wil gewoon dat t eruit ziet, zoals in de huidige draaitabel opgemaakt.
Ik heb t ook al eens met de rapportfilter geprobeerd, ipv de slicer, maar dat gaf dan weer andere problemen. Kan iemand me helpen?
Het document is heel groot, dus online opgeslagen https://1drv.ms/x/s!AsIc6FiZ_zTXkiM1p1Wxbzxzk2w7?e=SdpCzb
De output die ik kreeg, en er dus niet uitziet zoals gewenst, vind je in de bijlage
Hier is de code:
Ik heb een draaitabel (tabblad "per persoon"), waarbij ik van elk sliceritem "lesgever naam" een pdf wil opslaan. De code is hoofdzakelijk gebaseerd op wat ik op 't net gevonden heb. Er wordt effectief iets opgeslagen, maar:
- lay-out ziet er anders uit
- ik krijg een som ipv een gemiddelde te zien
- een absoluut getal ipv een percentage
Ik wil gewoon dat t eruit ziet, zoals in de huidige draaitabel opgemaakt.
Ik heb t ook al eens met de rapportfilter geprobeerd, ipv de slicer, maar dat gaf dan weer andere problemen. Kan iemand me helpen?
Het document is heel groot, dus online opgeslagen https://1drv.ms/x/s!AsIc6FiZ_zTXkiM1p1Wxbzxzk2w7?e=SdpCzb
De output die ik kreeg, en er dus niet uitziet zoals gewenst, vind je in de bijlage
Hier is de code:
Code:
Sub McrCodeOranjePerLesgever()
Dim pt As PivotTable
Dim sC As SlicerCache
Dim sI As SlicerItem, siDummy As SlicerItem
Dim co As ChartObject
Dim wsBlank As Worksheet
Set wsBlank = ActiveWorkbook.Sheets.Add
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
MsgBox "De bestanden worden gesaved in " & Application.DefaultFilePath 'laten weten aan user waar de bestanden opgeslagen worden (is nu de standdarddlocatie, kan later aangepast worden naar map op o-schijf of sharepoint
Set perpersoon = Worksheets("per persoon")
Worksheets("per persoon").Activate
Set sC = ActiveWorkbook.SlicerCaches("Slicer_lesgever_naam")
Set pt = sC.PivotTables(1)
For Each sI In sC.SlicerItems
sC.ClearManualFilter
For Each siDummy In sC.SlicerItems
siDummy.Selected = (sI.Name = siDummy.Name)
Next siDummy
' now only 1 sliceritem is selected and can be used
With pt.TableRange1
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set co = wsBlank.ChartObjects.Add(1, 1, .Width, .Height)
co.Select
co.Chart.Paste
co.Chart.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Application.DefaultFilePath & "\" & Left(sI.Name, InStrRev(ActiveWorkbook.Name, ".")) & "pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False
co.Delete
End With
Next sI
End With
End Sub
Bijlagen
Laatst bewerkt: