Необходимо изменить источник данных для всех сводных таблиц на нескольких листах - PullRequest
Новая
       25

Необходимо изменить источник данных для всех сводных таблиц на нескольких листах

0 голосов
/ 09 мая 2019

У меня есть несколько сводных таблиц на 5 листах, названных в коде.Источником данных для всех них является «данные CUIC», которые я обновляю ежедневно.

Я хочу изменить источник данных и обновить все сводные таблицы во всех моих рабочих листах.Код, который у меня есть, работает для одного листа, но я не знаю, как это сделать для нескольких сводных таблиц.

Private Sub CommandButton1_Click()
'PURPOSE: Automatically readjust a Pivot Table's data source range

Dim Data_sht As Worksheet
Dim Pivot_sht As Worksheet
Dim StartPoint As Range
Dim DataRange As Range
Dim PivotName As String
Dim NewRange As String

'Set Variables Equal to Data Sheet and Pivot Sheet
  Set Data_sht = ThisWorkbook.Worksheets("CUIC data")
  Set Pivot_sht = ThisWorkbook.Worksheets("Agent,Projections,Supervisor,Platinum Club - MTD,Platinum Club - YTD")


'Enter in Pivot Table Name
  PivotName = ("Projections,Supervisor,Agent,mtd,ytd")


'Dynamically Retrieve Range Address of Data
  Set StartPoint = Data_sht.Range("A1")
  Set DataRange = Data_sht.Range(StartPoint, StartPoint.SpecialCells(xlLastCell))

  NewRange = Data_sht.Name & "!" & _
    DataRange.Address(ReferenceStyle:=xlR1C1)

'Make sure every column in data set has a heading and is not blank (error prevention)
  If WorksheetFunction.CountBlank(DataRange.Rows(1)) > 0 Then
    MsgBox "One of your data columns has a blank heading." & vbNewLine _
      & "Please fix and re-run!.", vbCritical, "Column Heading Missing!"
    Exit Sub
  End If

'Change Pivot Table Data Source Range Address
  Pivot_sht.PivotTables(PivotName).ChangePivotCache _
    ThisWorkbook.PivotCaches.Create(xlDatabase, SourceData:=NewRange)



'Ensure Pivot Table is Refreshed
  Pivot_sht.PivotTables(PivotName).RefreshTable

'Complete Message
  MsgBox PivotName & "'s data source range has been successfully updated!"
End Sub
...