Pivottabel+vba

Slet ingen hjælp til dette ?

Så vidt jeg ved, kan man ikke bruge flere dataområder til samme pivottabel. En løsning kunne være at samle det variable antal dataark til ét dataark via VBA, og så lave pivottabellen på baggrund heraf.

Lige præcis sådan en løsning er også det jeg tror jeg ender ud med.

Er det noget du kan være behjælpelig med ?

Prøv med nedenstående kode. Foruden dine dataark skal du have et ark til opsamling af data. Jeg har i koden døbt dette ark "Total". For at kunne lave pivottabellen, skal du i arket "Total" indsætte kolonneoverskrifter (kolonne A-E).

Sub CollectAndPivot()

    Dim wks As Worksheet, wksTotal As Worksheet
    Dim NextRow As Integer, DataArea As Variant
    On Error Resume Next
   
    Set wksTotal = Worksheets("Total")
   
    Worksheets("Pivot").Delete

    Application.ScreenUpdating = False
    For Each wks In Worksheets
        If Not wks.Name = wksTotal.Name Then
            wks.Activate
            Range("A1").Select
            Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
            Selection.Copy
            wksTotal.Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    'Pivottabel sættes op
    DataArea = wksTotal.Range("A1").CurrentRegion.Address
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        DataArea).CreatePivotTable TableDestination:="", TableName:= _
        "Pivottabel1", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    ActiveSheet.Name = "Pivot"
   
    Application.ScreenUpdating = True
   
End Sub

Den brokker sig indtil videre over denne linie:

DefaultVersion:=xlPivotTableVersion10

Hvilken version af Excel anvender du?

Det blev testet på version 2002 DK

I 2007 DK kopiere den umiddelbart linierne og omdøber arket "Total" til "Pivot" men den laver ikke nogen Pivottabel.

Og der kommer heller ingen fjelmeddelelse.

Det som vil være mest optimalt.

At der altid er et ark = "Total" som alle linier fra alle andre ark end "Total" og "Pivot" kopieres over på. Arkets indhold slettes/overskrives hver gang makroen aktiveres.

At der altid er et ark = "Pivot". Pivottabellen eksisterer allerede men opdateres hver gang makroen aktiveres.

Kan det yderligere implementeres ?

Nedenstående kode forudsætter, at filen indeholder et "Total" ark og et "Pivot" ark. Ved hver kørsel ryddes "Pivot" og data, på nær overskrifterne i række 1, slettes fra "Total". I de nederste linier (dem med PivotFields) kan du selv indsætte hvordan de forskellige variabler skal repræsenteres i pivottabellen.

Sub CollectAndPivot()

    Dim wks As Worksheet, wksPivot As Worksheet, wksTotal As Worksheet
    Dim NextRow As Integer
    Dim PTCache As PivotCache, PT As PivotTable
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    Set wksPivot = Worksheets("Pivot")
    Set wksTotal = Worksheets("Total")
   
    Range(wksTotal.Range("A2"), wksTotal.Range("A2").End(xlDown).End(xlToRight)).Clear
    wksPivot.Cells.Clear

    'Data samles i "Total"
    For Each wks In Worksheets
        If Not wks.Name = wksTotal.Name And Not wks.Name = wksPivot.Name Then
            wks.Activate
            Range("A1").Select
            Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
            Selection.Copy
            wksTotal.Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    'Pivottabel sættes op i arket "Pivot"
    Set PTCache = ActiveWorkbook.PivotCaches.Add _
        (SourceType:=xlDatabase, _
        SourceData:=wksTotal.Range("A1").CurrentRegion.Address)
    Set PT = PTCache.CreatePivotTable _
        (TableDestination:=wksPivot.Cells(3, 1), _
        TableName:="Pivottable1")
    With PT
        .PivotFields("Overskrift A").Orientation = xlPageField
        .PivotFields("Overskrift B").Orientation = xlColumnField
        .PivotFields("Overskrift C").Orientation = xlRowField
        .PivotFields("Overskrift D").Orientation = xlDataField
    End With
    wksPivot.Activate
   
    Application.ScreenUpdating = True
   
End Sub

Det virker i hvert fald ikke i Excel 2000.

Jeg prøver senere i Excel 2007.

Jeg kan ikke få det til at virke.

Nu har jeg prøvet på Excel 2002 samt XP.

Det eneste er at de tlige viser et lille spørgsmål om at jeg skal markere et destinationsområde.

Men der sker intet. Den hverken kopierer til arket total eller laver nogen pivottabel.

Virker det kun i Excel 2007 tror du ? Det har jeg desværre først mulighed for at teste på senere.

Jeg vil meget meget gerne have det til at virke og takker for al den hjælp du gider assistere med.

Jeg anvender selv version 2003. Lad os prøve at gå et trin tilbage og kun samle data i "Total" arket. Du skal derfor slette arket "Pivot", således der tilbage kun er "Total" og x antal ark indeholdende data i kolonnerne A-E. Husk at cellerne A1..E1 i "Total" skal indeholde kolonne-overskrift.

Sub Collect()

    Dim wks As Worksheet, wksTotal As Worksheet
    Dim NextRow As Integer
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    Set wksTotal = Worksheets("Total")
   
    Range(wksTotal.Range("A2"), wksTotal.Range("A2").End(xlDown).End(xlToRight)).Clear

    'Data samles i "Total"
    For Each wks In Worksheets
        If Not wks.Name = wksTotal.Name Then
            wks.Activate
            Range("A1").Select
            Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
            Selection.Copy
            wksTotal.Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    Application.ScreenUpdating = True
   
End Sub

Hvis denne kodestump virker hos dig, kan du evt. gå videre ved at optage en makro, der udfra de samlede data i "Total", generere en pivottabel.

Den gør stadig det samme i Excel 2007.

Den skriver "Marker destinationsområde og tryk på enter" nede på statuslinien. Hvis jeg trykker enter sætter den en vlrdi ind i Total i celle A11.

Jeg har ændret makroen som nedenstående da alle ark inkl. Total har overskrifter fra celle A1 til H10 (der står forskellige ting i toppen). Alle er helt ens.
De reele overskrifter står i række 10.

Jeg har tidligere nævnt at arket også gik til kolonne E, jeg har udvidet det lidt:

Sub Collect()

    Dim wks As Worksheet, wksTotal As Worksheet
    Dim NextRow As Integer
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    Set wksTotal = Worksheets("Total")
   
    Range(wksTotal.Range("A11"), wksTotal.Range("A11").End(xlDown).End(xlToRight)).Clear

    'Data samles i "Total"
    For Each wks In Worksheets
        If Not wks.Name = wksTotal.Name Then
            wks.Activate
            Range("A11").Select
            Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
            Selection.Copy
            wksTotal.Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    Application.ScreenUpdating = True
   
End Sub

Driller det hvis de andre ark er skjult ?

Sidder jeg og dummer mig for vildt eller hvad ?

Ja, som koden ser ud pt. så går der ged i det, hvis data-arkene er skjult. Navnene på de skjulte ark vil godt blive fundet, men i stedet for at det enkelte dataark bliver aktiveret, er det Total-arket, der aktiveres og dermed kopieret fra.

Jeg faldt også lige over nedenstående, som du har tilrettet. Er det ikke korrekt, at de data, der skal kopieres fra de enkelte dataark starter i A1? Er det tilfældet, skal der stå A1 og ikke A11.

...
wks.Activate
Range("A11").Select <-- Her skal der stadig stå A1
Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
...

Nej det er rigtigt nok. De starter i A11.

Jeg har prøvet at vise alle ark. Det gør akkurat det samme ?

Virker det hos dig med Pivot og hele svineriet ?

Ja, her virker det hele OK. Du er velkommen til at maile Excel-filen til 3002lecxe@gmail.com, så vil jeg kigge på det i morgen.

Super pænt af dig.

Jeg sender det nu.

Jeg har oprettet arket "Pivot" igen og lavet et eksempel på hvordan min Pivottabel skal se ud. Håber du måske kan hjælpe med at få sat den automatisk op.

Der er nu lavet lidt justeringer i koden, så der testes for om de data, der skal kopieres fra dataark til Total-ark består af én eller flere rækker. Den tidligere kode håndterede ikke situationen korrekt, såfremt der kun var én række, der skulle kopieres. Den situation var jeg ikke lige opmærksom på. Koden ser nu ud som følger:

Sub CollectAndPivot()

    Dim wks As Worksheet, wksPivot As Worksheet, wksTotal As Worksheet, wksKopi As Worksheet
    Dim NextRow As Integer
    Dim PTCache As PivotCache, PT As PivotTable
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    Set wksPivot = Worksheets("Pivot")
    Set wksTotal = Worksheets("Total")
    Set wksKopi = Worksheets("Kopi")
   
    Range(wksTotal.Range("A11"), wksTotal.Range("A11").End(xlDown).End(xlToRight)).Clear
    wksPivot.Cells.Clear

    'Data samles i "Total"
    For Each wks In Worksheets
        If Not wks.Name = wksTotal.Name And Not wks.Name = wksPivot.Name And Not wks.Name = wksKopi.Name Then
            wks.Activate
            Range("A11").Select
            If IsEmpty(ActiveCell.Offset(1, 0)) Then
                Range(Selection, Selection.End(xlToRight)).Select
            Else
                Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
            End If
            Selection.Copy
            wksTotal.Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    'Pivottabel sættes op i arket "Pivot"
    wksPivot.Activate
    Application.CutCopyMode = False
    Set PTCache = ActiveWorkbook.PivotCaches.Add _
        (SourceType:=xlDatabase, _
        SourceData:=wksTotal.Range("A11").CurrentRegion.Address)
    Set PT = PTCache.CreatePivotTable _
        (TableDestination:=wksPivot.Cells(3, 1), _
        TableName:="Pivottabel1")
   
    PT.PivotFields("Projekt").Orientation = xlPageField
    With PT.PivotFields("Medarb.nr.")
        .Orientation = xlRowField
        .Position = 1
    End With
    With PT.PivotFields("Medarbejdernavn")
        .Orientation = xlRowField
        .Position = 2
    End With
    With PT.PivotFields("Udført arbejde")
        .Orientation = xlRowField
        .Position = 3
    End With
    PT.AddDataField ActiveSheet.PivotTables("Pivottabel1").PivotFields("Timer"), _
    "Sum af Timer", xlSum
   
    'Subtotal for Medarb.nr. fjernes
    Range("A4").Select
    PT.PivotFields("Medarb.nr.").Subtotals = _
    Array(False, False, False, False, False, False, False, False, False, False, False, False)
   
    'Subtotal for Medarbejdernavn fjernes
    Range("B4").Select
    PT.PivotFields("Medarbejdernavn").Subtotals = _
    Array(False, False, False, False, False, False, False, False, False, False, False, False)
   
    Application.ScreenUpdating = True
   
End Sub

Den kopierer "kun" kolonne A og sætter ind på arket Total.

Og den kopierer ikke alle rækker fra dataarkene ?

Lidt mere forklarerende:

Den har kun indsat medarbejdernummer i kolonne A på Total-arket således:

59
51
53
60
61
52
50

Men der er f.eks. flere rækker på arket "53" så det tal burde figurerer 3 flere gange på Totalarket.
Og så mangler de yderligere kolonner selvfølgelig.

Men Pivottabellen er dannet... og ser rigtig ud.

Jeg kan se, at du har placeret koden i arket "Total". Prøv i stedet at flytte koden til et modul (højreklik på VBAProject i typisk venstre side --> Insert --> Module)

Så virker det med arket Total.. whuhuuu

Men Sum af timer vises ikke i Pivottabellen

Mystisk, det er nedenstående kodelinie, der skal sørge for, at Sum af timer vises. Ser det præcis ud som dit? Nu den ikke viser Sum af Timer, hvad gør den så?

...
PT.AddDataField ActiveSheet.PivotTables("Pivottabel1").PivotFields("Timer"), _
"Sum af Timer", xlSum
...

Den viser alle de anre felter i Pivot med underliggende valgmuligheder.

Men selve Dataområdet er bare blankt og "sum af timer" knappen vises heller ikke.

Jeg har sendt filen retur med den kode, der virker hos mig.

Det virker også i Excel 2007 som jeg nu har testet i.

Men ikke i 2002 som jeg prøvede tidligere !

Jeg takker for assistancen. Kom endelig med et svar for at få de velfortjente point.

Nu vedr. forskel på Excel 2007 og 2002:

Ved du hvorfor jeg kan bruge Kalender Kontrolelementet i Excel 2007 (på Vista Platform), men ikke i Excel 2007 (på Xp platform). Jeg kan slet ikke vælge det i vba ? (Additional controls)

Det er godt, at der er noget, der virker :-) Jeg er ikke klar over hvilke dele af koden, som version 2002 ikke bryder sig om.

Jeg må være dig svar skyldig vedr. kalender kontrolelementet i version 2007 på de platforme. Jeg har på min version 2003 prøvet at optage det at sætte kalender kontrolelementet ind. Det ser ud som følger:

ActiveSheet.OLEObjects.Add(ClassType:="MSCAL.Calendar.7", Link:=False, _
DisplayAsIcon:=False, Left:=324, Top:=132.75, Width:=354, Height:=235.5).Select

Måske du kan anvende tilsvarende i version 2007.