lijst met draaitabellen

Status
Niet open voor verdere reacties.
J

jofred

Gebruiker
Lid geworden
16 dec 2006
Berichten
172
Ik heb een Excel-bestand met een aantal draaitabellen en ik wil graag in één werkblad wat informatie daarover vastleggen.
Nu ben ik al zover dat ik een vast lijstje kan bijwerken met een event-procedure
In de sheet Blad1 heb ik van alle draaitabellen in het bestand een benoemd bereik van één cel aangemaakt met de naam van de draaitabel.

Code: 
Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
Set Rng = Sheets("Blad1").Range(Target.Name)
With Rng 'info van de draaitabel wegschrijven
    .Value = Target.Name 'de naam van de draaitabel
    .Offset(0, 1).Value = Target.SourceData 'de brongegevens
    .Offset(0, 2).Value = Target.RefreshDate 'de verversingsdatum/tijd
    .Offset(0, 3).Value = Sh.Name 'de naam van het werkblad waar de draaitabel staat
End With
End Sub

Als ik nu een nieuwe draaitabel aanmaak, moet ik handmatig een nieuw bereik toevoegen aan deze sheet
Is er ook een mogelijkheid om dit meer dynamisch te maken?
 
Hoi,

Als je een nieuwe draaitabel aanmaakt, staat die dan op een nieuw werkblad?
Zo ja, dan kun je proberen om in VBA, in "this workbook" middels code te zetten dat, indien er een nieuw werkblad aangemaakt wordt, en indien er veranderingen zijn gebeurd op dat werkblad, de nodige gegevens naar blad 1 worden doorgegeven.
Indien de draaitabel op een reeds bestaand werkblad komt te staan, kun je werken met code achter het werkblad, bij "Worksheet_Change" bijvoorbeeld.

Groetjes

Code: 
Option Explicit

Private Sub Workbook_NewSheet(ByVal Sh As Object)
[COLOR="#FF0000"]Hier kan code komen [/COLOR]
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
[COLOR="#FF0000"]Hier kan code komen [/COLOR]
End Sub
 
Cheetahke dank voor je reactie.
Je hebt me met je reactie weer verder aan het denken gezet en ik ben tot een (andere) oplossing gekomen.
Via de foutafhandeling zorg ik ervoor dat als een draaitabel niet bestand omdat er geen benoemd bereik van is, er automatisch een nieuw celbreik wordt aangemaakt.

Hieronder de code

Code: 
Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim strDtNaam As String
Dim strOvzNaam As String
Dim intNieuweRij As Integer

Set Wb = ThisWorkbook
strOvzNaam = "Overzicht Draaitabellen"
'Kijken of een werkblad Overzicht draaitabellen bestaat en zonodig aanmaken
On Error Resume Next
Set Ws = Worksheets(strOvzNaam)
If Err.Number = 9 Then
    Set Ws = Worksheets.Add(After:=Sheets(Worksheets.Count))
    With Ws
        .Name = strOvzNaam
        .Cells(1, 1).Value = "Naam draaitabel"
        .Cells(1, 2).Value = "Brongegevens"
        .Cells(1, 3).Value = "Werkblad"
        .Cells(1, 4).Value = "Datum/tijd verversing"
        .Cells(1, 5).Value = "Door"
        .Cells(1, 1).CurrentRegion.Font.Bold = True
    End With
End If

On Error GoTo Foutafhandeling
strDtNaam = "DTS" & Sh.Index & "_" & Target.Name
Set Rng = Ws.Range(strDtNaam)

Foutafhandeling:
Select Case Err.Number
Case 0 ' de actie is goed uitgevoerd
    GoTo Wegschrijven
Case 1004 'het benoemde bereik bestaat niet
  intNieuweRij = Ws.Cells(1, 1).CurrentRegion.Rows.Count + 1
  Wb.Names.Add Name:=strDtNaam, RefersToR1C1:="='" & Ws.Name & "'!R" & intNieuweRij & "C1"
  Set Rng = Ws.Range(strDtNaam)
Case Else
    Bericht = "Niet gedefinieerde fout, informeer applicatiebeheer" _
            & Chr(10) & Chr(10) & "Fout: " & Err.Number & " - " & Err.Description
    MsgBox Bericht, vbOKOnly + vbCritical, "Fout!"
    Exit Sub
End Select

Wegschrijven:
With Rng 'info van de draaitabel wegschrijven
    .Value = Target.Name 'de naam van de draaitabel
    .Offset(0, 1).Value = Target.SourceData 'de brongegevens
    .Offset(0, 2).Value = Sh.Name 'de naam van het werkblad waar de draaitabel staat
    .Offset(0, 3).Value = Target.RefreshDate 'de verversingsdatum/tijd
    .Offset(0, 4).Value = Environ("username") 'de gebruikerscode van de ververser
End With
Ws.Columns("A:D").EntireColumn.AutoFit

End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan