Simplified VBA for quick run

[ShanShami]

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.

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

 

[vletm]

ShanShami​

You seems to have three almost same codes PT1_OD(), PT2_OD(), PT3_OD().
...
About Your SheetCopy
You should modify those Select and Seletion away.

 

[ShanShami]

Thank you.
I do have multiple filter names and multiple tables. How do I add it here. Due to 10000 words restriction, I am attaching the file with VBA codes.
Please assist.

 

[vletm]

ShanShami​

When drafting a question, try and lay out the question in a clear and concise way.
You seems to missed something from Your original posting ...
I tried to do some minor modifications with Your #3 reply code.
Note, I had to skip to test it.