Hello All,
I have below VBA, but it is taking a very long time to run these. And I have to run these macros more than 100 times as this file is saved in share folder and multiple staff is using the same.
Below are only 4 VBA codes but I have more than 15 VBA code which are used changing the pivot table filters based on cell values.
How do I simplify these VBAs to run quickly.
I have below VBA, but it is taking a very long time to run these. And I have to run these macros more than 100 times as this file is saved in share folder and multiple staff is using the same.
Below are only 4 VBA codes but I have more than 15 VBA code which are used changing the pivot table filters based on cell values.
How do I simplify these VBAs to run quickly.
Code:
Sub PT1_OD()
Dim filtvalues As Variant, aItm As Variant
Dim pt As PivotTable
Dim PF As PivotField
Dim tmpFltr As String, strFltr As String, arrFltr As Variant
Dim aItmFlts As String
With Sheets("Pivot")
Set pt = .PivotTables("PT1")
filtvalues = .Range("B1:B2").Value
End With
Set PF = pt.PivotFields("[DDS].[Merged].[Merged]")
PF.ClearAllFilters
For Each aItm In filtvalues
aItmFlts = "[" & aItm & "]"
On Error Resume Next
tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
PF.VisibleItemsList = Array(tmpFltr)
If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
On Error GoTo 0
Next aItm
If strFltr <> "" Then
arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
PF.VisibleItemsList = arrFltr
Else
End If
End Sub
Sub PT2_OD()
Dim filtvalues As Variant, aItm As Variant
Dim pt As PivotTable
Dim PF As PivotField
Dim tmpFltr As String, strFltr As String, arrFltr As Variant
Dim aItmFlts As String
With Sheets("Pivot")
Set pt = .PivotTables("PT2")
filtvalues = .Range("B1:B2").Value
End With
Set PF = pt.PivotFields("[DDS].[Merged].[Merged]")
PF.ClearAllFilters
For Each aItm In filtvalues
aItmFlts = "[" & aItm & "]"
On Error Resume Next
tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
PF.VisibleItemsList = Array(tmpFltr)
If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
On Error GoTo 0
Next aItm
If strFltr <> "" Then
arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
PF.VisibleItemsList = arrFltr
Else
End If
End Sub
Sub PT3_OD()
Dim filtvalues As Variant, aItm As Variant
Dim pt As PivotTable
Dim PF As PivotField
Dim tmpFltr As String, strFltr As String, arrFltr As Variant
Dim aItmFlts As String
With Sheets("Pivot")
Set pt = .PivotTables("PT3")
filtvalues = .Range("B1:B2").Value
End With
Set PF = pt.PivotFields("[DDS].[Merged].[Merged]")
PF.ClearAllFilters
For Each aItm In filtvalues
aItmFlts = "[" & aItm & "]"
On Error Resume Next
tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
PF.VisibleItemsList = Array(tmpFltr)
If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Merged]", "&" & aItmFlts, 2)
On Error GoTo 0
Next aItm
If strFltr <> "" Then
arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
PF.VisibleItemsList = arrFltr
Else
End If
End Sub
Sub SheetCopy()
Sheets("Report").Copy After:=Workbooks("Fare").Sheets(Workbooks("Fare").Sheets.Count)
On Error Resume Next
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Name = Range("B3").Value
Workbooks("Report").Activate
On Error GoTo 0
End Sub