j3nn
08-13-2019, 03:58 AM
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
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