• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Simplified VBA for quick run

ShanShami

Member
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.


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
 

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.
 
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.
 

Attachments

  • Book1_simplified macro query.xlsm
    25.3 KB · Views: 1

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.
 

Attachments

  • Book1_simplified macro query.xlsm
    25 KB · Views: 1
Back
Top