Simplified VBA code to generate faster output

S

shansakhi

Active Member
Joined
Apr 5, 2008
Messages
292
Office Version
  1. 365
Platform
  1. Windows
Hello All,
Is there a way to simplify below various macro into one to generate faster output.
Currently it is taking a longer time.
Below macro is filtering various pivots and finally copying the data linked to all pivot to another workbook named "Fare".

Code: 
.[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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT1_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT1_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT2_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT2_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT3_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT3_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT4_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("PT4")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT5_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("PT5")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT6_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("PT6")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT7_Cabin()
    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("PT7")
        filtvalues = .Range("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Cabin Class].[Cabin Class]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "Cabin Class_P7"
    End If
End Sub
Sub PT7_Origin()
    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("PT7")
        filtvalues = .Range("BE2:BE3").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Sector].[Sector]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT8_Cabin()
    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("PT8")
        filtvalues = .Range("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Cabin Class].[Cabin Class]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "Cabin Class_P8"
    End If
End Sub
Sub PT8_Destination()
    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("PT8")
        filtvalues = .Range("BF2:BF3").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Sector].[Sector]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT9_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("PT9")
        filtvalues = .Range("BI1:BI2").Value
    End With

    Set PF = pt.PivotFields("[POS_OD].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT9_ODCabin()
    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("PT9")
        filtvalues = .Range("BG1:BG2").Value
    End With

    Set PF = pt.PivotFields("[POS_OD].[COMPARTMENT_CODE].[COMPARTMENT_CODE]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[COMPARTMENT_CODE]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[COMPARTMENT_CODE]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub

Sub SheetCopy()
On Error Resume Next
Cells.Select
    Range("B3").Activate
    Selection.Copy
    Windows("Fare.xlsx").Activate
    Sheets.Add after:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
      ActiveSheet.Name = Range("B4").Value
    
    On Error GoTo 0

    End Sub

]
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
Here is the full code.. given earlier was not correctly pasted.

VBA Code: 
Sub Pricing()
Call PT1_OD
Call PT1_POS
Call PT1_Cabin
Call PT2_OD
Call PT2_POS
Call PT2_Cabin
Call PT3_OD
Call PT3_POS
Call PT3_Cabin
Call PT4_OD
Call PT5_OD
Call PT6_OD
Call PT7_Cabin
Call PT7_Origin
Call PT8_Cabin
Call PT8_Destination
Call PT9_OD
Call PT9_ODCabin
Call SheetCopy
End Sub


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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT1_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT1_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT2_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT2_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    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
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT3_POS()
    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("A1:A2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Sales POS].[Sales POS]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sales POS]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT3_Cabin()
    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("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[DDS].[Cabin].[Cabin]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT4_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("PT4")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT5_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("PT5")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT6_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("PT6")
        filtvalues = .Range("B1:B2").Value
    End With

    Set PF = pt.PivotFields("[QSI].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT7_Cabin()
    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("PT7")
        filtvalues = .Range("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Cabin Class].[Cabin Class]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "Cabin Class_P7"
    End If
End Sub
Sub PT7_Origin()
    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("PT7")
        filtvalues = .Range("BE2:BE3").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Sector].[Sector]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT8_Cabin()
    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("PT8")
        filtvalues = .Range("C1:C2").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Cabin Class].[Cabin Class]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Cabin Class]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "Cabin Class_P8"
    End If
End Sub
Sub PT8_Destination()
    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("PT8")
        filtvalues = .Range("BF2:BF3").Value
    End With

    Set PF = pt.PivotFields("[Bkd   FRCT].[Sector].[Sector]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[Sector]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT9_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("PT9")
        filtvalues = .Range("BI1:BI2").Value
    End With

    Set PF = pt.PivotFields("[POS_OD].[OD].[OD]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[OD]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub
Sub PT9_ODCabin()
    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("PT9")
        filtvalues = .Range("BG1:BG2").Value
    End With

    Set PF = pt.PivotFields("[POS_OD].[COMPARTMENT_CODE].[COMPARTMENT_CODE]")
    PF.ClearAllFilters

    For Each aItm In filtvalues
        aItmFlts = "[" & aItm & "]"
        On Error Resume Next
            tmpFltr = WorksheetFunction.Substitute(PF.Name, "[COMPARTMENT_CODE]", "&" & aItmFlts, 2)
            PF.VisibleItemsList = Array(tmpFltr)
            If Err = 0 Then strFltr = strFltr & "|" & WorksheetFunction.Substitute(PF.Name, "[COMPARTMENT_CODE]", "&" & aItmFlts, 2)
        On Error GoTo 0
    Next aItm

    If strFltr <> "" Then
        arrFltr = Split(Right(strFltr, Len(strFltr) - 1), "|")
        PF.VisibleItemsList = arrFltr
    Else
        MsgBox "None of the values exist"
    End If
End Sub

Sub SheetCopy()
On Error Resume Next
Cells.Select
    Range("B3").Activate
    Selection.Copy
    Windows("Fare.xlsx").Activate
    Sheets.Add after:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
      ActiveSheet.Name = Range("B4").Value
    
    On Error GoTo 0

    End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

ghull99
  • Question Question
Attempting VBA to refresh "Chart Title" based on Pivot Filters. Filter1 works in VBA, but title doesn't update based on filter2.
Replies
0
Views
50
ghull99
ghull99
A
  • Question Question
getting application defined error
Replies
3
Views
103
Domenic
D
S
  • Solved
VBA for Pivot to filter on cell value not working
2
Replies
18
Views
1K
Alex Blakenburg
A
H
  • Solved
Macro to Filter Pivot Table
Replies
2
Views
782
howard
H
F
  • Question Question
PivotFields property
Replies
2
Views
208
FrancescoAFR
F

Forum statistics

Threads
1,223,941
Messages
6,175,537
Members
452,652
Latest member
eduedu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top