1

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
Improve this question
2
  • 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 Commented Aug 27, 2018 at 9: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. Commented Aug 27, 2018 at 9:56

1 Answer 1

Reset to default
1

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

Improve this answer
Sign up to request clarification or add additional context in comments.

3 Comments

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...
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
@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.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.