AW: Pivotdatenquelle in unzähligen Exceldateien ändern
18.08.2019 13:48:57
fcs
Hallo Kai Uwe,
ich hab mal ein entsprechendes Makro geschrieben.
Es funktioniert auch unter der neuesten Excel-Version (Office 365 in 2019)
LG
Franz
Sub Updatei_Piovot_Quelle()
Dim wkb As Workbook
Dim wksPivot As Worksheet
Dim objPivotTab As PivotTable
Dim strSource As String, strSourceData As String
Dim varPfad As Variant, strDatei As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit den zu aktualisierenden Dateien auswählen"
If .Show = -1 Then
varPfad = .SelectedItems(1)
Else
Exit Sub
End If
End With
strSource = "Vorlage.xls" 'name der Quelldatei der Pivot-Tabellenberichte
strDatei = Dir(varPfad & Application.PathSeparator & "*.xls", vbNormal)
Application.ScreenUpdating = False
Do Until strDatei = ""
Application.StatusBar = "Aktualisiere Datei: " & strDatei
Select Case LCase(strDatei)
Case LCase(strSource), LCase(ThisWorkbook.Name)
'Bei diesen Dateinamen Pivot-Update nicht ausführen
Case Else
Set wkb = Application.Workbooks.Open(varPfad _
& Application.PathSeparator & strDatei, UpdateLinks:=False)
Set wksPivot = wkb.Worksheets(1)
wksPivot.Activate
If wksPivot.PivotTables.Count > 0 Then
Set objPivotTab = wksPivot.PivotTables(1)
strSourceData = objPivotTab.SourceData
' MsgBox "PivotSource: " & strSourceData
'Überprüfen, ob Quelldatei in anderem Verzeichnis
If Left(strSourceData, InStr(strSourceData, "]")) _
"'" & Mid(varPfad, InStrRev(varPfad, Application.PathSeparator) + 1) _
& Application.PathSeparator & "[" & strSource & "]" Then
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, _
SourceData:="'" & varPfad & Application.PathSeparator _
& "[" & strSource & "]Prüfvorschrift'!C1"
' ActiveSheet.PivotTableWizard SourceType:=xlDatabase, _
SourceData:="'" & varPfad & Application.PathSeparator _
& "[" & strSource & "]Prüfvorschrift'!A1:D7" 'für meine Test-Dateien
Application.DisplayAlerts = False
wkb.Save
Application.DisplayAlerts = True
End If
End If
wkb.Close savechanges:=False
End Select
strDatei = Dir
Loop
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Fertig", vbOKCancel, "Pivottabs - Quelle aktualisieren"
End Sub