Optimising Macro that uses Select and Activate

Question

I created the attached. It works. I want to make it fast!

Info: The "Macro" & "Promo Claims" workbooks along with the "csv" folder sit in a folder called "Template".

Purpose: To create a template for a process used daily/weekly/monthly.

Output/Result: I want this to run faster as when the csv files reach 100 or greater, time elapsed increase exponentially.

I understand select activate slows things down but I can't get my dim variables set correctly and working right.

Sub Metcash_claim_import()
'Metcash Claims Import Macro

Dim SourceWB As Workbook        'Metcash Consolidate Macro File
Dim SourceShtMcr As Worksheet
Dim SourceShtFrml As Worksheet
Dim SourceShtMcrCell As Range
Dim SourceShtFrmlCell As Range
Dim DestWB As Workbook          'Metcash Consolidate Promo Claims
Dim DestPrmClm As Worksheet
Dim DestClmDet As Worksheet
Dim DestPrmClmCell As Range
Dim DestClmDetCell As Range
Dim FPath As String             'csv Folder containing raw data export
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook
Dim FiName As String            'saves promo claims file to new xls file
Dim FiPath As String
Dim i As Long                   'count for total files ---- not currently used
Dim k As Long           'count for total files ---- not currently used
Dim t As Integer                'count for total files ---- not currently used
Dim StartTime As Double         'time elapsed counter
Dim MinutesElapsed As String
Dim DestWBpath As String

    StartTime = Timer           'starts timer - Remember time when macro starts

    NeedForSpeed                'speeds up macro

Workbooks.Open (ThisWorkbook.path & "\Metcash Consolidate Promo Claims.xlsm")

Set DestWB = Workbooks("Metcash Consolidate Promo Claims.xlsm")
Set DestPrmClm = DestWB.Worksheets("Promo Claims")
Set DestClmDet = DestWB.Worksheets("Claim Summary")
Set DestPrmClmCell = DestPrmClm.Range("A1")                         
Set DestClmDetCell = DestPrmClm.Range("A4")

Set SourceWB = ThisWorkbook
Set SourceShtMcr = SourceWB.Sheets("Macro")
Set SourceShtFrml = SourceWB.Sheets("Formula")
Set SourceShtMcrCell = SourceShtMcr.Range("B7")
Set SourceShtFrmlCell = SourceShtFrml.Range("J20:AA21")

Call GetLastFolderName          'calls Function to get Payment number


    DestWB.Worksheets("Promo Claims").Activate
    Rows("2:" & Rows.Count).ClearContents   ' clears promo claims tab ---- This needs to change to remove rows as only clear contents
    DestWB.Worksheets("Claim Summary").Activate
    Range("A4:C10000").ClearContents        ' clears claim summary tab ---- can this be dynamic? Never more than 10,000


FPath = ThisWorkbook.path & "\csv\"                                 'path to CSV files
fCSV = Dir(FPath & "*.csv")                                         'start the CSV file listing

    On Error Resume Next


    Do While Len(fCSV) > 0

        SourceWB.Sheets("Formula").Activate
        Range("J20:AA21").Copy

        Set wbCSV = Workbooks.Open(FPath & fCSV)                    'open a CSV file
        Set wbCSV = ActiveWorkbook


            Range("J20").Select                     'Copies formulas from Macro file and pastes into csv file
            ActiveSheet.Paste
            Last_Row = Range("A" & Rows.Count).End(xlUp).Row       'finds last row in data - must be dynamic
            Range("J21:AA21").Copy Range("J22:AA" & Last_Row)
            Application.Calculation = xlCalculationAutomatic        'calc formulas
            Application.Calculation = xlCalculationManual
            Range("J21:AA" & Last_Row).Copy
            DestWB.Worksheets("Promo Claims").Activate          'pastes calc formulas in opened workbook
            Range("A1").Select                      'gets last blank cell on tab
            Selection.End(xlDown).Select
            Selection.End(xlDown).Select
            Selection.End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            wbCSV.Close savechanges:=False
            fCSV = Dir                                  'ready next CSV
    Loop

Set wbCSV = Nothing


    DestWB.Worksheets("Promo Claims").Activate            'cleaning "case quantity" and "size" fields


        Columns("J:J").Select
    Selection.Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="G", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        Columns("I:I").Select
    Selection.Replace What:="2x150", Replacement:="2x150GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="2x175", Replacement:="2x175GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="4x160", Replacement:="4x160GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="6x175", Replacement:="6x175GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    On Error Resume Next                'removes blank cells
    With Range("E:E")
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With

    Range("A1").Select
    Columns.AutoFit             'Auto fits Columns




    SourceWB.Sheets("Macro").Activate           'copies data that user originally pasted into Macro workbook
    Range("B7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    DestWB.Worksheets("Claim Summary").Activate     'data pasted into claims file
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    ActiveWorkbook.RefreshAll           'used to refresh 2 pivot tables on DestWB.Worksheets("Claim Summary") worksheet

    Columns.AutoFit             'Auto fits Columns


    FiName = Range("C1")                'saves Promo Claims file as Metcash payment no. and saves in same location 
    FiPath = ThisWorkbook.path
    ActiveWorkbook.SaveAs FileName:=FiPath & "\" & FiName & ".xlsx", _
    FileFormat:=51, CreateBackup:=False

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")        'stops timer - Determine how many seconds code took to run

    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation        'Msg box for elapsed time & Claims consldaited          'how can this include the total no. of csv files opened


    ResetSpeed

End Sub



Sub GetLastFolderName()

Dim LastFolder                  As String
Dim FullPath                    As String
Dim c                           As Long

FullPath = ThisWorkbook.path

c = InStrRev(FullPath, "\")
LastFolder = Right(FullPath, Len(FullPath) - c)

ThisWorkbook.Worksheets("Macro").Cells(5, 5) = LastFolder

End Sub


Sub NeedForSpeed()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

End Sub

Sub ResetSpeed()
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

You have been using a `With Range(....)` statement in your code to alter a specific range. It's suprising you are using `.Select` and `.Activate` even though you have implemented the right technique. Have a good look in the link given by @Pierre44. Also, a better place to get your code reviewed for optimalization would be [SE Code Review](https://codereview.stackexchange.com/) — JvdV, Aug 27 '18 at 09:46
When you use `On Error Resume Next` you must follow it as soon as possible with `On Error GoTo 0`, and test for the potential error. — chris neilsen, Aug 27 '18 at 09:56

Pierre44 · Accepted Answer · 2018-08-27T10:43:59.303

Removing the .Select

The main issue of your code are the .Select that are to be found a few times.

To remove them you can check the question: How to avoid using Select in Excel VBA

In a lot of cases you just need to do changed like these:

Columns("J:J").Select
    Selection.Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

To:

Columns("J:J").Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Removing the .Activate

Same as for .Select you can switch from

SourceWB.Sheets("Formula").Activate
        Range("J20:AA21").Copy

To

SourceWB.Sheets("Formula").Range("J20:AA21").Copy

In general, if you always define on which worksheet/workbook your range is, you do not need to activate

Avoid to Copy Paste:

Copy pasting often pass by the clipboard, therefore taking a lot of memory space. In this link there are good ways to make your code faster, including Copy pasting.

http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm

Last Row / Last Cell:

In your code you use .select mainly to find the last row or last cell of your worksheet. If you want to get the last row without selecting is and scrolling down you can type a formula like this:

Dim LastRow As Long
LastRow = mainWS.Range("A" & Rows.Count).End(xlUp).Row

If your code evolves and the last row changes, you can reenter the line later to reupdate your last row. If you do the same with the last column:

Dim LastCol As Long
LastCol = mainWS.Cells(1, Columns.Count).End(xlToLeft).Column

You will get your last cell as below:

cells(LastRow, LastCol)

One example to summarize:

SourceWB.Sheets("Macro").Activate           'copies data that user originally pasted into Macro workbook
Range("B7").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

DestWB.Worksheets("Claim Summary").Activate     'data pasted into claims file
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Could become:

DestWB.Worksheets("Claim Summary").Range("A4").value = SourceWB.Sheets("Macro").Cells(LastRow, LastCol).value

If your LastRow and LastCol are the last rows and columns of this Worksheet

Thanks for the quick replied. I knew I was on the right path with technique Im just struggling to implement. The .select and .activate slows the macro down but I cant get my variables to work... — alowflyingpig, Aug 27 '18 at 09:57
What do you mean you can t get your variable to work? It is fine if you just stop selecting by replacing like in my example — Pierre44, Aug 27 '18 at 10:35
@Pierrr44 I will give this a try tomorrow at work and revert back. Was reading the link above to help remove the .select .activate and to set varuabts etc. Thank you for the help here. — alowflyingpig, Aug 27 '18 at 13:33

Optimising Macro that uses Select and Activate

1 Answers1