Consulting

Results 1 to 7 of 7

Thread: Help to make VBA Model in Excel run quicker

  1. #1
    VBAX Newbie
    Joined
    Aug 2019
    Posts
    3
    Location

    Question Help to make VBA Model in Excel run quicker

    I am fairly new to VBA and I have managed to put together the below macro but it takes so long to run. Can anyone give me some tips to make this run quicker? Any help would be really appreciated.

    1) I have a large report with groups (Capabilities) and sub-groups (Performance Groups)
    2) I need to create separate smaller reports, one for each Group and then a separate tab within each report for each sub-group within that group
    3) There is a command button to bring up a userform for the user to select a group and then click "Generate"
    4) The Generate button filters the main large report by group and copies one column containing Unique IDs under this group
    5) The below macro has been replicated for each group and depending on the user's selection, depends on what macro is called to run
    6) The below macro first opens up the corresponding template file, pastes the column of Unique IDs into "group tab"
    7) This tab is then "copy & paste values" to remove the pre-existing formula and reduce the overall file size
    8) Then this "group" tab is filtered by the first sub-group and the results are copied into a "sub-group" tab
    9) Three formula's are added into the table and because it is a table the formula auto-fill down
    10) This process is replicated for each sub-group under this group
    11) Three tabs are then hidden & CutCopyMode is disabled
    12) The template file is then re-saved with a new name & closed



    Sub TaxPack()
    
    
    Application.StatusBar = "Macro is running...Please Wait."
    
    
    Dim wkb As Workbook
    Dim sht As Worksheet
    
    Set wkb = Workbooks.Open("")    'Removed on purpose
    Set sht = wkb.Sheets("Blank Capability")
    
    
    'Paste the copied data from another workbook, paste into "sht" and then values are copied & pasted to remove formula & reduce filesize.
    
    
    sht.Activate
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
        ActiveSheet.ListObjects("Capability").Range.AutoFilter Field:=5
        ActiveSheet.Range("D8:BB8", Range("D8:AA8").End(xlDown)).Copy
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
    
    
    'Filter the data for the first Capability, paste into its own tab & insert formula
    
        
        ActiveSheet.ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax Central")
        ActiveSheet.Range("D8:AA8", Range("D8:AA8").End(xlDown)).Copy
        
    wkb.Sheets("Tax Central").Activate
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
        Range("R8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
        Range("x8").Select
            ActiveCell.FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
        Range("y8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
    
    
    'Filter the data for the second Capability, paste into its own tab & insert formula
    
    
    sht.Activate
        ActiveSheet.ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax Corps")
        ActiveSheet.Range("D8:AA8", Range("D8:AA8").End(xlDown)).Copy
    
    
    wkb.Sheets("Tax Corps").Activate
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
        Range("r8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
        Range("x8").Select
            ActiveCell.FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
        Range("y8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
    
    
    'Filter the data for the third Capability, paste into its own tab & insert formula
    
    
    sht.Activate
        ActiveSheet.ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax FS")
        ActiveSheet.Range("D8:AA8", Range("D8:AA8").End(xlDown)).Copy
    
    
    wkb.Sheets("Tax FS").Activate
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
        Range("r8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
        Range("x8").Select
            ActiveCell.FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
        Range("y8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
    
    
    'Filter the data for the last Capability, paste into its own tab & insert formula
    
    
    sht.Activate
        ActiveSheet.ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax NM")
        ActiveSheet.Range("D8:AA8", Range("D8:AA8").End(xlDown)).Copy
    
    
    wkb.Sheets("Tax NM").Activate
        ActiveSheet.Range("D8").PasteSpecial Paste:=xlPasteValues
        Range("r8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
        Range("x8").Select
            ActiveCell.FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
        Range("y8").Select
            ActiveCell.FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
    
    
    'Cancels CutCopyMode and hides worksheets
    
    
    Application.CutCopyMode = False
    
    wkb.Sheets("Lookups").Visible = xlSheetHidden
    wkb.Sheets("Band Mvmt").Visible = xlSheetHidden
    wkb.Sheets("Blank PG Tab").Visible = xlSheetHidden
    wkb.Sheets("Blank Capability").Visible = xlSheetHidden
    
    
    'Returns active sheet to first tab
    
    
    ActiveWorkbook.Worksheets("Contents").Select
    
    
    'Saves file with new title & closes
    
    
    Dim FName As String
    Dim FPath As String
    
    FPath = ""  'Removed on purpose
    FName = wkb.Sheets("Lookups").Range("B14")
    
    
    ActiveWorkbook.SaveAs Filename:=FPath & FName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
    
    
    Application.StatusBar = ""
    
    
    End Sub
    Last edited by j3nn; 08-13-2019 at 08:42 AM. Reason: More information to be provided

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    25,079
    Location
    Hard to help nmuch as you don't say what the code is doing, or what it is doing it on, but this should be quicker

    Sub TaxPack()
    Dim wkb As Workbook
    Dim sht As Worksheet
    
        Application.StatusBar = "Macro is running...Please Wait."
        Application.ScreenUpdating = False
    
        Set wkb = Workbooks.Open("")    'Removed on purpose
        With wkb
        
            Set sht = .Sheets("Blank Capability")
        
            With sht
            
                'Paste the copied data from another workbook, paste into "sht" and then values are copied & pasted to remove formula & reduce filesize.
                .Range("D8").PasteSpecial Paste:=xlPasteValues
                .ListObjects("Capability").Range.AutoFilter Field:=5
                .Range("D8:BB8", .Range("D8:AA8").End(xlDown)).Copy
                .Range("D8").PasteSpecial Paste:=xlPasteValues
        
        
                'Filter the data for the first Capability, paste into its own tab & insert formula
                .ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax Central")
                .Range("D8:AA8", .Range("D8:AA8").End(xlDown)).Copy
            End With
        
            With .Sheets("Tax Central")
            
                .Range("D8").PasteSpecial Paste:=xlPasteValues
                .Range("R8").FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
                .Range("x8").FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
                .Range("y8").FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
            End With
    
            With sht.Activate
            
                'Filter the data for the second Capability, paste into its own tab & insert formula
                .ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax Corps")
                .Range("D8:AA8", .Range("D8:AA8").End(xlDown)).Copy
            End With
    
            With .Sheets("Tax Corps")
            
                .Range("D8").PasteSpecial Paste:=xlPasteValues
                .Range("r8").FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
                .Range("x8").FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
                .Range("y8").FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
            End With
    
            With sht
            
                'Filter the data for the third Capability, paste into its own tab & insert formula
                .ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax FS")
                .Range("D8:AA8", .Range("D8:AA8").End(xlDown)).Copy
            End With
    
            With .Sheets("Tax FS")
        
                .Range("D8").PasteSpecial Paste:=xlPasteValues
                .Range("r8").FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
                .Range("x8").FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
                .Range("y8").FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
            End With
            
            With sht
            
                'Filter the data for the last Capability, paste into its own tab & insert formula
                .ListObjects("Capability").Range.AutoFilter Field:=5, Criteria1:=Array("Tax NM")
                .Range("D8:AA8", .Range("D8:AA8").End(xlDown)).Copy
            End With
    
            With .Sheets("Tax NM")
            
                .Range("D8").PasteSpecial Paste:=xlPasteValues
                .Range("r8").FormulaR1C1 = "=IFNA(VLOOKUP([Performance Rating],Lookups!C1:C2,2,0),"""")"
                .Range("x8").FormulaR1C1 = "=IF([Next FY Benchmark]="""","""",[Next FY Benchmark]-[CY Benchmark])"
                .Range("y8").FormulaR1C1 = "=IFNA(INDEX('Band Mvmt'!R5C3:R56C54,MATCH([CY Benchmark],'Band Mvmt'!R5C2:R56C2,1),MATCH([Next FY Benchmark],'Band Mvmt'!R4C3:R4C54,1)),"""")"
            End With
    
            'Cancels CutCopyMode and hides worksheets
            Application.CutCopyMode = False
            
            .Sheets("Lookups").Visible = xlSheetHidden
            .Sheets("Band Mvmt").Visible = xlSheetHidden
            .Sheets("Blank PG Tab").Visible = xlSheetHidden
            .Sheets("Blank Capability").Visible = xlSheetHidden
    
            'Returns active sheet to first tab
            .Worksheets("Contents").Select
    
    
            'Saves file with new title & closes
    Dim FName As String
    Dim FPath As String
    
            FPath = ""  'Removed on purpose
            FName = .Sheets("Lookups").Range("B14")
        
            .SaveAs Filename:=FPath & FName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            .Close
        End With
        
        Application.ScreenUpdating = True
        Application.StatusBar = ""
    End Sub
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    VBAX Newbie
    Joined
    Aug 2019
    Posts
    3
    Location
    Thanks xld - I have added more information to my original post. Hope this helps

  4. #4
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,495
    Avoid any 'select' or 'activate' in VBA.
    Avoid Excelforumulae in VBA
    Use arrays to perform calculations, operations.

    Reduce the interaction with the workbook to
    - the reading of data
    - the writing of results from operations in VBA

  5. #5
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    25,079
    Location
    Quote Originally Posted by j3nn View Post
    Thanks xld - I have added more information to my original post. Hope this helps
    Did you try the code that I posted?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  6. #6
    VBAX Newbie
    Joined
    Aug 2019
    Posts
    3
    Location
    Quote Originally Posted by xld View Post
    Did you try the code that I posted?
    Unfortunately it doesn't seem to have improved the processing time. My main file is about 7.4MB and each template file is just under 1.5MB, but they are all saved in the same network folder. Any other ideas?

  7. #7
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    25,079
    Location
    If you are accessing the files over a network, you are restricted to the network speed, VBA cannot do much about that.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •