PDA

View Full Version : Help to make VBA Model in Excel run quicker



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

Bob Phillips
08-13-2019, 05:00 AM
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
08-13-2019, 08:43 AM
Thanks xld - I have added more information to my original post. Hope this helps

snb
08-13-2019, 08:49 AM
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
08-13-2019, 08:51 AM
Thanks xld - I have added more information to my original post. Hope this helps

Did you try the code that I posted?

j3nn
08-13-2019, 09:11 AM
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
08-13-2019, 09:56 AM
If you are accessing the files over a network, you are restricted to the network speed, VBA cannot do much about that.