3
\$\begingroup\$

I'm trying to optimize some VBA that I put together. I know that using Select a lot slows down performance quite a bit so I've been trying to cut that out where I can. Is there anything else in my code that I can change or do differently to improve performance? Thank you in advance!

Sub PP_Formatting_Saving()

Application.ScreenUpdating = False

'Ungroups sheets by selecting Wksht 2
Worksheets(2).Select

'Input 1 into Cell AK1 then Multiply columns to convert to number
Range("AK1").Value = "1"
Range("AK1").Copy

Range("N" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False

Range("AA" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False

Range("G" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False

Range("AK1").ClearContents

'Format Amount as Accounting
Range("J" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Style = "Comma"


'Format header color & bold
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 12632256
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Selection.Font.Bold = True

'Autofit all columns
Cells.Select
Cells.EntireColumn.AutoFit
Columns("O:O").ColumnWidth = 40

'Filter all headers
Selection.AutoFilter



'Unwrap Text in sheet 1
Worksheets(1).Select
Cells.Select
With Selection
    .WrapText = False
End With


'Format Amount as Accounting
Range("C" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Style = "Comma"

'Input 1 into Cell AK then Multiply columns to convert to number
Range("AK1").Value = "1"
Range("AK1").Copy
Range("B" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False

'Autofit all columns
Cells.Select
Cells.EntireColumn.AutoFit


'Format header color & bold
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 12632256
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Selection.Font.Bold = True

'Filter all headers
Selection.AutoFilter


Dim ws As Worksheet
Dim wbNew As Workbook

'Select PP sheet, filter all cells on Variable1 in Column 31.          Copy all of that then paste in new sheet, rename sheet as PP1.      UsedRange selects all cells with value in it
Sheets("PP").Select
ActiveSheet.UsedRange.AutoFilter Field:=31, Criteria1:= _
    "Variable1"
Cells.Select
Range("Y1005").Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = "PP1"

'Select BK sheet, filter all cells on Variable2 in Column 16.  Copy all of that then paste to new sheet, rename as BK1.  UsedRange selects all values in worksheet.
Sheets("Bk").Select
ActiveSheet.UsedRange.AutoFilter Field:=16, Criteria1:= _
    "Variable2"
Cells.Select
Range("O15").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = "BK1"

'Copy BK & PP in Array then save as new workbook
Worksheets(Array("BK", "PP")).Copy
Set wbNew = ActiveWorkbook

'Naming the workbook w/ date format
wbNam = "BK_PP_"
dt = Format(DateAdd("m", -1, Now), "yyyy_mm")

'Save location
ActiveWorkbook.SaveAs "\\user\location\" & wbNam & dt & ".xlsx"

'Close new workbook that just saved
ActiveWorkbook.Close

'Delete sheets created in original workbook
Sheets("PP1").Delete
Sheets("BK1").Delete

End sub
\$\endgroup\$
3
\$\begingroup\$

Most times you have Range.Select followed by Selection.Something you can remove the Select and Selection to leave it Range.Something. This helps clarify what the code is doing. The same may be true of Worksheet.Select (or Activate). But doing this with a worksheet will alter any unqualified Range variables in your code that follows.

Range without VariableName.Range refer to the ActiveSheet and can lead to issues if you're not aware of this. My first step was to go through and everything after Worksheets(2).Select to fully qualify it with

Dim secondSheet As Worksheet
Set secondSheet = Worksheets(2)

Range("AK1").Value = "1" then became secondSheet.Range("AK1").Value = "1" giving me a lot more confidence that removing the .Select shouldn't alter the code. I did the same with Worksheets(1).Select as well. After that I went after the Range.Selects.


Range("N" & Rows.Count).End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False

I took the above Select and Selection to be finding where the last cell on a specific column. Range("N" & Rows.Count).End(xlUp).Select became what follows. My choice of variable names are self describing, helping you immediately understand what the code is there for.

Dim lastCell as range
set lastCell = secondSheet.Range("N" & Rows.Count).End(xlUp)

Going up from this last cell to get a contiguous range Range(Selection, Selection.End(xlUp)).Select became

Dim modifyRange as Range
Set modifyRange = secondSheet.Range(lastCell, lastCell.End(xlUp))

Lastly replace the Selection in Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False with modifyRange and it's looking a lot better. But this is being done in 3 places on the secondSheet and once on firstSheet. Rather than having duplicated code, create a Sub procedure ConvertToNumeric that takes in 2 parameters ByVal sheetToUse As Worksheet and ByVal columnToFindLastCellOn As String. The names let you know when typing the name ConvertToNumeric<space> and getting intellisense to show you the names of the arguments you'll supply. Any future changes are made in this single location now be reflected wherever it's called at ensuring the update is correct.

Private Sub ConvertToNumeric(ByVal sheetToUse As Worksheet, ByVal columnToFindLastCellOn As String)
    Dim helperCell As Range
    Set helperCell = sheetToUse.Range("AK1")
    helperCell.value = "1"
    helperCell.Copy

    Dim lastCell As Range
    Set lastCell = sheetToUse.Cells(Rows.Count, columnToFindLastCellOn).End(xlUp)

    Dim modifyRange As Range
    Set modifyRange = sheetToUse.Range(lastCell, lastCell.End(xlUp))
    modifyRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False

    helperCell.ClearContents
End Sub

You have a few places with comments like 'Format Amount as Accounting that are describing what you're doing. When this occurs it's pretty safe to make that chunk of code be it's own Sub or Function. Sub if it doesn't return a value or Function if it does.

Using the same idea as above Range("J" & Rows.Count).End(xlUp).Select became a Dim lastCell As Range variable and the Range(Selection, Selection.End(xlUp)).Select became Dim modifyRange As Range. You get

Private Sub FormatAsAccounting(ByVal sheetToUse As Worksheet, ByVal columnToApplyFormatTo As String)
    Dim lastCell As Range
    Set lastCell = sheetToUse.Cells(Rows.Count, columnToApplyFormatTo).End(xlUp)

    Dim modifyRange As Range
    Set modifyRange = sheetToUse.Range(lastCell, lastCell.End(xlUp))
    modifyRange.Style = "Comma"
End Sub

It's called in code FormatAsAccounting secondSheet, "J" where secondSheet is a worksheet variable and columnToApplyFormatTo is a string that tells you what column you'll be using. Admittedly the modifyRange variable isn't actually needed and sheetToUse.Range(lastCell, lastCell.End(xlUp)).Style ... could be used but serves to illustrate how as code becomes simpler many times it helps clean itself.

The same thing occurred with headers as well.


When you get to the saving a workbook that has copies of your worksheets you have variables Dim ws As Worksheet that's never used and Dim wbNew As Workbook that's assigned but then never used. There is also dt and wbNam, neither of which are declared. In the VBE coding window go to Tools>Options>Require Variable Declaration. This will put Option Explicit into any new module and requires you to Dim every single variable. It takes more thought and effort to code, but doing something well generally takes effort. Future-you will thank current-you for doing so because it'll save you from many needless issues in your code. BTW Debug>Compile VBAProject (Alt+D+L for keyboard shortcut) is your friend. That'll tell the compiler to compile the code and if something isn't correct it'll alert you by taking you straight there. Keep doing that until there's no more compile-time problems.

Back to the code.

You're selecting a sheet, filtering the sheet, selecting all cells on the sheet to copy that information to a sheet that was just added. This is done for the sheet "PP" and "BK". Those copied sheets are then copied to a new workbook only to be deleted in your current workbook. You can avoid this by creating a new workbook and using that variable.

Dim saveBook As Workbook
Set saveBook = Workbooks.Add

Putting that code into a Sub and having your cursor on the word Add if you press Ctrl+i or Edit>Quick Info you should see Add([Template]) As Workbook appear. This indicates the Add function on the Workbooks collection returns a Workbook object, which coincidentally is what saveBook has been dimensioned as. Right clicking on Add and choosing Definition (3rd from bottom) will take you to the object browser where you can see at the bottom pane what I just described. This gives you a new workbook to use that you'll eventually save where you want. The Object Browser is another topic, but learning to use it will help tremendously.

You can directly copy a sheet by using the Copy procedure on a worksheet object and tell it where to be copied to with either the Before or After argument.

Dim ppSheet As Worksheet
Set ppSheet = Sheets("pp")
ppSheet.Copy Before:=saveBook.Worksheets(1)

As part of your eventual file name dt isn't descriptive. I used monthPriorDate since that's what you're doing with DateAdd. Putting all the pieces together you get SaveExternalCopy.

Private Sub SaveExternalCopy()
    Dim saveBook As Workbook
    Set saveBook = Workbooks.Add

    Dim ppSheet As Worksheet
    Set ppSheet = Sheets("pp")
    ppSheet.UsedRange.AutoFilter field:=31, Criteria1:="Variable1"

    ppSheet.Copy Before:=saveBook.Worksheets(1)
    Dim ppCopy As Worksheet
    Set ppCopy = saveBook.Worksheets(1)
    ppCopy.Name = "PP1"


    Dim bkSheet As Worksheet
    Set bkSheet = Sheets("Bk")
    bkSheet.UsedRange.AutoFilter field:=16, Criteria1:="Variable2"

    bkSheet.Copy After:=ppCopy
    Dim bkCopy As Worksheet
    Set bkCopy = Sheets.Add(After:=bkSheet)
    bkCopy.Name = "BK1"

    Dim monthPriorDate As String
    monthPriorDate = Format(DateAdd("m", -1, Now), "yyyy_mm")

    'Dont forget to delete any default sheets that are created
    'when the workbook is first created.

    saveBook.SaveAs "\\user\location\" & "BK_PP_" & monthPriorDate & ".xlsx"
    saveBook.Close
End Sub

My final code ended up as follows. Save a copy before running the code as I've not 100% fully tested everything and there might be an unforseen issue that wasn't caught.

PP_Formatting_Saving now is shorter and everything it's doing is self-descriptive. Each Sub that's called is doing one thing, which makes it easier to fix a problem when looking at 10-20 lines of code instead of a single block of around 90 lines of code. Comments are mostly gone. Comments should describe the why of something being done not the what since what is happening should be apparent. Why is for when one choice was made over another, something like 'Doing it this way over <OtherWaysName> is 5 times faster.

Public Sub PP_Formatting_Saving()

    Application.ScreenUpdating = False

    Dim secondSheet As Worksheet
    Set secondSheet = Worksheets(2)
    secondSheet.Select 'This may possible be removable

    ConvertToNumeric secondSheet, "N"
    ConvertToNumeric secondSheet, "AA"
    ConvertToNumeric secondSheet, "G"

    FormatAsAccounting secondSheet, "J"
    FormatTheHeaderOf secondSheet

    secondSheet.Cells.EntireColumn.AutoFit
    secondSheet.Columns("O:O").ColumnWidth = 40
    secondSheet.Cells.AutoFilter '¿Does this turn it on or off? 'Filter all headers

    Dim firstSheet As Worksheet
    Set firstSheet = Worksheets(1)
    firstSheet.Activate 'This may possible be removable also
    firstSheet.Cells.WrapText = False

    FormatAsAccounting firstSheet, "C"
    ConvertToNumeric firstSheet, "B"
    firstSheet.Cells.EntireColumn.AutoFit
    FormatTheHeaderOf firstSheet
    firstSheet.Cells.AutoFilter

    SaveExternalCopy
End Sub

Private Sub ConvertToNumeric(ByVal sheetToUse As Worksheet, ByVal columnToFindLastCellOn As String)
    Dim helperCell As Range
    Set helperCell = sheetToUse.Range("AK1")
    helperCell.value = "1"
    helperCell.Copy

    Dim lastCell As Range
    Set lastCell = sheetToUse.Cells(Rows.Count, columnToFindLastCellOn).End(xlUp)

    Dim modifyRange As Range
    Set modifyRange = sheetToUse.Range(lastCell, lastCell.End(xlUp))
    modifyRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False

    helperCell.ClearContents
End Sub

Private Sub FormatTheHeaderOf(ByVal sheetToUse As Worksheet)
    Dim header As Range
    Set header = sheetToUse.Range(sheetToUse.Range("A1"), sheetToUse.Range("A1").End(xlToRight))
    With header.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = RGB(192, 192, 192) 'RGB(192,192,192) = 12632256
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    header.Font.Bold = True
End Sub

Private Sub FormatAsAccounting(ByVal sheetToUse As Worksheet, ByVal columnToApplyFormatTo As String)
    Dim lastCell As Range
    Set lastCell = sheetToUse.Cells(Rows.Count, columnToApplyFormatTo).End(xlUp)

    Dim modifyRange As Range
    Set modifyRange = sheetToUse.Range(lastCell, lastCell.End(xlUp))
    'NumberFormat could possibly be used instead of Style
    'I'm not sure if you have altered the "Comma" Style though
    'modifyRange.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
    modifyRange.Style = "Comma"
End Sub

Private Sub SaveExternalCopy()
    Dim saveBook As Workbook
    Set saveBook = Workbooks.Add

    Dim ppSheet As Worksheet
    Set ppSheet = Sheets("pp")
    ppSheet.UsedRange.AutoFilter field:=31, Criteria1:="Variable1"

    ppSheet.Copy Before:=saveBook.Worksheets(1)
    Dim ppCopy As Worksheet
    Set ppCopy = saveBook.Worksheets(1)
    ppCopy.Name = "PP1"


    Dim bkSheet As Worksheet
    Set bkSheet = Sheets("Bk")
    bkSheet.UsedRange.AutoFilter field:=16, Criteria1:="Variable2"

    bkSheet.Copy After:=ppCopy
    Dim bkCopy As Worksheet
    Set bkCopy = Sheets.Add(After:=bkSheet)
    bkCopy.Name = "BK1"

    Dim monthPriorDate As String
    monthPriorDate = Format(DateAdd("m", -1, Now), "yyyy_mm")

    'Dont forget to delete any default sheets that are created
    'when the workbook is first created.

    saveBook.SaveAs "\\user\location\" & "BK_PP_" & monthPriorDate & ".xlsx"
    saveBook.Close
End Sub

Lastly Rubberducks Code Inspections brought up a lot of what I addressed and has been very helpful to my VBA knowledge and improving my coding habits. I'm a contributor and openly biased in favor of it.

\$\endgroup\$
1
  • 1
    \$\begingroup\$ I would also recommend some Const declarations to eliminate the "magic numbers" and "magic letters". For example Const TELEPHONE_NUMBER as String = "N" so the call becomes ConvertToNumeric secondSheet, TELEPHONE_NUMBER. That way if someone moves the telephone number column in the worksheet in the future, a simple update to the Const is obvious and fixes everything instead of wondering why you're suddenly trying to convert "City" to a number. \$\endgroup\$ – FreeMan Apr 27 '18 at 11:40
1
\$\begingroup\$

Why not just move the sheet and then format it?

Sub CopySheets()
    Dim sourceBook As Workbook
    Dim targetSheet As Worksheet
    Set sourceBook = ActiveWorkbook
    Set targetSheet = sourceBook.Sheets(1)
    NewBooks targetSheet
End Sub

Private Sub NewBooks(ByVal targetSheet As Worksheet)
    Dim targetBook As Workbook
    Set targetBook = Workbooks.Add
    targetSheet.Copy before:=targetBook.Sheets(1)
    FormatSheet targetSheet
End Sub

Private Sub FormatSheet(ByVal targetSheet As Worksheet)
    With targetSheet
        .Columns.AutoFit
        '..etc
    End With
End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.