Macro for Changing Pivot Tables Dates

[Jar888]

Hi all! So, I've got a bit of a brainchild to a previous problem. Just wondering if there's any potential way that I can speed up the process of it changing the dates across my pivot tables? Any help would be great!

Thanks

Sub PivotMaster()
' Macro for updating the dates in the delay pivot tables
' With no other Excel spreadsheets open: ~10sec
' With other Excel spreadsheets open: ~9min
Dim curmonth As String
Dim curmonth1S As String
Dim prevmonth As String
Dim prevmonth1S As String
Dim dateS As String
Dim yesterday As String
Dim yesterdayD As Date
Dim curmonth1D As Date
Dim prevmonth2D As Date
Dim d As Range
Dim k As Long

yesterday = DatePart("d", Range("I38")) & "-" & MonthName(DatePart("m", Range("I38")), True) 'Transforms yesterdays date into a "DD-MMM" format

curmonth = MonthName(DatePart("m", yesterday), True)
curmonth1S = "1/" & curmonth & "/" & DatePart("yyyy", yesterday) 'First day of the current month
curmonth1D = curmonth1S

prevmonth2D = curmonth1D - 1 'Last day of the previous month
prevmonth = MonthName(DatePart("m", prevmonth2D), True)
prevmonth1S = "1/" & prevmonth 'First day of previous month


'---------------Updating delay dates for single date pivot tables-------------------

    ActiveSheet.PivotTables("PivotTable3").PivotFields("Date").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable3").PivotFields("Date").CurrentPage = _
        yesterday

    ActiveSheet.PivotTables("PivotTable4").PivotFields("Date").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable4").PivotFields("Date").CurrentPage = _
        yesterday

'---------------Updating delay dates for multi date pivot tables--------------------
k = 1
Do Until k > DatePart("d", yesterday) 'Creates collection of dates from the first of the curent month until yesterday's date
dateS = k & "-" & curmonth

ActiveSheet.PivotTables("PivotTable14").PivotFields("Date").CurrentPage = _
        "(All)"
    ActiveSheet.PivotTables("PivotTable14").PivotFields("Date").PivotItems(dateS).Visible = True

    ActiveSheet.PivotTables("PivotTable15").PivotFields("Date").CurrentPage = _
        "(All)"
    ActiveSheet.PivotTables("PivotTable15").PivotFields("Date").PivotItems(dateS).Visible = True

k = k + 1

Loop

k = 1

'---------------De-select dates in the previous month if applicable-----------------
If curmonth = "Jan" Or DatePart("d", yesterday) = 1 Then
    Do Until k > DatePart("d", prevmonth2D)
    dateS = k & "-" & prevmonth
    
    ActiveSheet.PivotTables("PivotTable14").PivotFields("Date").CurrentPage = _
        "(All)"
    ActiveSheet.PivotTables("PivotTable14").PivotFields("Date").PivotItems(dateS).Visible = False
    
    ActiveSheet.PivotTables("PivotTable15").PivotFields("Date").CurrentPage = _
        "(All)"
    ActiveSheet.PivotTables("PivotTable15").PivotFields("Date").PivotItems(dateS).Visible = False
    
    k = k + 1
    Loop
Else

End If

ActiveWorkbook.RefreshAll

End Sub

 

[Jar888]

Any help would be appreciated. Thanks