Help to make VBA Model in Excel run quicker

[j3nn]

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

[Bob Phillips]

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

[j3nn]

Thanks xld - I have added more information to my original post. Hope this helps

[snb]

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

[Bob Phillips]

Thanks xld - I have added more information to my original post. Hope this helps

Did you try the code that I posted?

[j3nn]

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?

[Bob Phillips]

If you are accessing the files over a network, you are restricted to the network speed, VBA cannot do much about that.