Improve speed of a recorded macro

M

mkseto

New Member
Joined
Aug 14, 2018
Messages
38
I've only started to learn macro.
I need to work on a spreadsheet everyday (different number of rows) to basically do the following:
1) In worksheet "Combined", find the total amount of "deposits" for each account (column "J") and also total number of items on deposit (column "M").
2) Copy the results from above to another worksheet "Results" with the same headings.

With no knowledge with VBA, I managed to record a macro that works, but very slow because I have to assume a maximum of 20,000 rows of data, so I had to copy everything down the 20,000 rows and calculations are done for 20,000 rows.

Below is the recorded macro, any suggestion that can make this run faster would be much appreciated (the last few lines are VBA codes I found via Google and added to my reocrded codes):
Code: 
Sub Convert()
'
' Convert Macro
'


'
    Sheets("Combined").Select
    Rows("1:2").Select
    Selection.Delete Shift:=xlUp
    Columns("J:J").Select
    Selection.Replace What:="~*", 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
    Range("N2").Select
    ActiveCell.FormulaR1C1 = "=RC[-10]&"",""&RC[-5]&"",""&RC[-4]"
    Range("N2").Select
    Selection.Copy
    Range("N20001").Select
    Range("N3:N20001").Select
    Range("N20001").Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("N:N").Select
    Range("N20001").Activate
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("N2:N20001").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "O2"), Unique:=True
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "=SUMIF(C[-2],RC[-1],C[-4])"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "=SUMIF(C[-3],RC[-2],C[-4])"
    Range("P2:Q2").Select
    Selection.Copy
    Range("P3").Select
    Range("P3:Q20001").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("P:Q").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("R2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]>0,""True"",""False"")"
    Range("R2").Select
    Selection.Copy
    Range("R3").Select
    Range("R3:R20001").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("R:R").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("J:J").Select
    Selection.Replace What:="/", 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
    Range("R2").Select
    Application.CutCopyMode = False
    Columns("P:P").Select
    Selection.NumberFormat = "#,##0.00"
    Columns("Q:Q").Select
    Selection.NumberFormat = "#,##0"
    Range("R2").Select
        Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Set Source = ActiveWorkbook.Worksheets("Combined")
    Set Target = ActiveWorkbook.Worksheets("Results")
    j = 2     ' Start copying to row 2 in target sheet
    For Each c In Source.Range("R3:R20001") 
        If c = "True" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
    Sheets("Convert").Select
    Range("C3").Select
End Sub
 
Last edited by a moderator:

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
Welcome to the Board!

There are a number of things you can do to increase speed, such as:
1. Eliminate a lot of "Select" and "Activate" statements. Most times when you have one line end with "Select" or "Activate" and the next line begins with "Selection" or "ActiveCell", you can combine the two lines together. It is usually not necessary to select the ranges to work with them, and doing so actually slows down the code.
2. You can often apply your formulas to an entire range all at once.
3. You can limit your loops to only run down as far as the bottom of the data (no need to "high-end it" with a large value).
4. You can suppress calculations and screen updating until the macro completes, which eliminates screen flickering and intermediate calculations, so your code should run faster.

Here is a first run at it, but we can still make more improvements.
Code: 
Sub Convert()
'
' Convert Macro
'
'
    Dim c As Range
    Dim j As Integer
    Dim mySource As Worksheet
    Dim myTarget As Worksheet
    Set mySource = ActiveWorkbook.Worksheets("Combined")
    Set myTarget = ActiveWorkbook.Worksheets("Results")
    Dim lastRow As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Sheets("Combined").Select

    Rows("1:2").Delete Shift:=xlUp

    With Columns("J:J")
        .Replace What:="~*", Replacement:="#", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="~?", Replacement:="/", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="/", Replacement:="?", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="#", Replacement:="*", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End With

    Range("N3:N20001").FormulaR1C1 = "=RC[-10]&"",""&RC[-5]&"",""&RC[-4]"
    Range("N3:N20001").Value = Range("N3:N20001").Value

    Range("N2:N20001").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "O2"), Unique:=True

    Range("P2:P20001").FormulaR1C1 = "=SUMIF(C[-2],RC[-1],C[-4])"
    Range("Q2:Q20001").FormulaR1C1 = "=SUMIF(C[-3],RC[-2],C[-4])"
    Range("P2:Q20001").Value = Range("P2:Q20001").Value

    Range("R3:R20001").FormulaR1C1 = "=IF(RC[-2]>0,""True"",""False"")"
    Range("R3:R20001").Value = Range("R3:R20001").Value

    Columns("P:P").NumberFormat = "#,##0.00"
    Columns("Q:Q").NumberFormat = "#,##0"

    'Find last row with data in column R
    lastRow = Cells(Rows.Count, "R").End(xlUp).Row

    j = 2 ' Start copying to row 2 in target sheet
    For Each c In mySource.Range("R3:R" & lastRow)
        If c = "True" Then
            mySource.Rows(c.Row).Copy myTarget.Rows(j)
            j = j + 1
        End If
    Next c

    Sheets("Convert").Select
    Range("C3").Select
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub
Here are a few things we can still do, with more information.

Like I limited the loop at the bottom by finding the last line in column R with data, we can do the same above and replace all our row "20001" references. However, we would need you to tell us exactly which column we can look at to dynamically figure out what row is our last row of data (in other words, can you tell us which column will always have data in it for every row with data)?

Also, we can replace the Loop at the bottom of your code with a Filter. One way to is just copy all the data over, Filter on column R, and delete the hidden (or unhidden rows, depending on how you filtered). Loops are notoriously slow, so if we can eliminate them, it will also speed up your code. I would just want to know how many columns you have data in (is it columns A-R?), and if there is any header on the data, and if so, is it just row 2, or rows 1 and 2 together?
 
Upvote 0
Thank you for the quick reply.
Regarding your question, column "A" will always have data. The columns are from "A" to "M" for a total of 13 columns.
Below are some sample data (new to this board, couldn't figure out how to upload a file). I'm using "Curr" + "CR_RT" + "CR_ACCT" combination as an identifier. All row having the same identifier will have the "Amount" and "Items" field added up for the total, then the "Curr" + "CR_RT" + "CR_ACCT" fields will be copied over to the "Results" sheet along with the total "Amount" and Total "Items". I tried to run your code but somehow getting all "false" for the statement "=IF(RC[-2]>0,""True"",""False"" but I don't understand why.

DateCtrEntryCurrTypeISNUnit NumberSERIALCr_RTCr_AcctCodeAMOUNTItems
30-Jul-2018CAL5309CADRegular3000902814 00000069436700009-003124-171-089$5,238.257
30-Jul-2018CAL5309CADRegular3000902822 00000158616500009-003124-171-089$4,967.138
30-Jul-2018CAL5309CADRegular3000902831 00000062591900009-003124-171-089$1,813.481
30-Jul-2018CAL5309CADRegular3000902833 00000155627700009-003124-171-089$4,114.386
30-Jul-2018CAL5309CADRegular300090284300009040300009-003119-016-451$32,642.703
30-Jul-2018CAL5309CADRegular300090284700009058000009-003112-845-351$1,575.001
30-Jul-2018CAL5309CADRegular300090284900009018200009-003123-794-051$20,222.701
30-Jul-2018CAL5309CADRegular300090285100009029000009-003000-080-251$10,153.882
30-Jul-2018CAL5309CADRegular300090285400009058200009-003103-762-151$132,862.912
30-Jul-2018CAL5309CADRegular300090285700009310200009-003134-259-151$478,419.562
30-Jul-2018CAL5309CADRegular300090286000009078400009-003000-035-651$132,670.773
30-Jul-2018CAL5309CADRegular300090286400009002608519-003102-917-251$6,595.751
30-Jul-2018CAL5309CADRegular300090286600009446400007-003000-006-751$54,658.504
30-Jul-2018CAL5309CADRegular300090287100009 00009-003122-204-151$3,785.001
30-Jul-2018CAL5309CADRegular300090287300009007700009-003147-274-551$642.001
30-Jul-2018CAL5309CADRegular300090287702539 00009-003109-602-351$2,305.857
30-Jul-2018CAL5309CADRegular300090288502539 00009-003109-686-651$350.202
30-Jul-2018CAL5309CADRegular300090288802539 00009-003129-500-551$36.251
30-Jul-2018CAL5309CADRegular300090289002539 00009-003129-531-051$30.001
30-Jul-2018CAL5309CADRegular300090289202539 00009-003131-609-051$150.001
30-Jul-2018CAL5309CADRegular300090289402539 00009-003131-608-251$150.001
30-Jul-2018CAL5309CADRegular300090289602539 00009-003109-602-351$1,636.001
30-Jul-2018CAL5309CADRegular300090289802539 00009-003109-686-651$3,371.111

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>
 
Last edited by a moderator:
Upvote 0
What row does your header and data start on before running any macros?
 
Upvote 0
Joe4 said:
What row does your header and data start on before running any macros?
Click to expand...

I run another macro to merge other worksheets into the "Combined" tab and somehow it triplicates the header row. In other words, for this macro in question, the top 3 rows are always the same headers, therefore I need to delete 2 of them. Data starts with the 4th row prior to running this macro.
 
Upvote 0
So it looks like that you are summarizing the data in columns N-R.
But when you copy over to your Results tab, you are copying columns A-R. So of the values in columns A-M are being cut off.
Do you care about the data in those columns for your Results tab, or just the summarized data?
 
Upvote 0
Columns A to M are the before-consolidation data, therefore I don't need them. I also don't need column N because that's basically joint values of columns D+I+J.
Column O is the "unique records" out of column N via advanced filter, therefore is what I copy along with columns P and Q (P and Q are the SUMIF totals, which is the information I need from this whole exercise). In other words, I need columns O,P,Q but column O needs to be separated (i.e. text-to-column) into 3 different fields (i.e. originally columns D, I, J).

Hope I'm not confusing you.
 
Last edited by a moderator:
Upvote 0
OK, I think this should give you what you want:
Code: 
Sub Convert()
'
' Convert Macro
'
'
    Dim mySource As Worksheet
    Dim myTarget As Worksheet
    Dim lastRow As Long
    
    Set mySource = ActiveWorkbook.Worksheets("Combined")
    Set myTarget = ActiveWorkbook.Worksheets("Results")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Sheets("Combined").Select

    Rows("1:2").Delete Shift:=xlUp

    With Columns("J:J")
        .Replace What:="~*", Replacement:="#", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="~?", Replacement:="/", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="/", Replacement:="?", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Replace What:="#", Replacement:="*", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End With
    
'   Find last row with data in column A
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    Range("N2:N" & lastRow).FormulaR1C1 = "=RC[-10]&"",""&RC[-5]&"",""&RC[-4]"
    Range("N2:N" & lastRow).Value = Range("N2:N" & lastRow).Value

    Range("N2:N" & lastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "O2"), Unique:=True

'   Remove any duplicates left after filter
    Application.DisplayAlerts = False
    Range("O2:O" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
    
'   Find new last row, using column O
    lastRow = Cells(Rows.Count, "O").End(xlUp).Row

    Range("P2:P" & lastRow).FormulaR1C1 = "=SUMIF(C[-2],RC[-1],C[-4])"
    Range("Q2:Q" & lastRow).FormulaR1C1 = "=SUMIF(C[-3],RC[-2],C[-4])"
    Range("P2:Q" & lastRow).Value = Range("P2:Q" & lastRow).Value

    Columns("P:P").NumberFormat = "#,##0.00"
    Columns("Q:Q").NumberFormat = "#,##0"

'   Copy data to target sheet
    mySource.Range("O2:Q" & lastRow).Copy myTarget.Range("A2")

    Sheets("Convert").Select
    Range("C3").Select
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Wow, the speed improvement is totally amazing. My original code took about 2-3 minutes but yours was INSTANT!!!!!
There's only a problem with some cells having wildcard values. I tried to look at the codes but really know have enough VBA knowledge to figure out anything, so maybe you can help one final time (really appreciate your time). I have revised the sample data so you can test with this:
ReportDateRegionEntryCurrencyWorkTypeISNBranch TransitSERIALCr_RTCr_AcctTRANCODEAMOUNTCountOfItems
ReportDateRegionEntryCurrencyWorkTypeISNBranch TransitSERIALCr_RTCr_AcctTRANCODEAMOUNTCountOfItems
ReportDateRegionEntryCurrencyWorkTypeISNBranch TransitSERIALCr_RTCr_AcctTRANCODEAMOUNTCountOfItems
30-Jul-18CAL5309CADRegular300090281469436700009-003124-171-089$5,238.257
30-Jul-18CAL5309CADRegular3000902822158616500009-003124-171-089$4,967.138
30-Jul-18CAL5309CADRegular300090283162591900009-003124-171-089$1,813.481
30-Jul-18CAL5309CADRegular3000902833155627700009-003124-171-089$4,114.386
30-Jul-18CAL5309CADRegular3000902843940300009-003119-016-451$32,642.703
30-Jul-18CAL5309CADRegular3000902847958000009-003************51$1,575.001
30-Jul-18CAL5309CADRegular3000902849918200009-003123-794-051$20,222.701
30-Jul-18CAL5309CADRegular3000902851929000009-003000-080-251$10,153.882
30-Jul-18CAL5309CADRegular3000902854958200009-003103-7*2-151$132,862.912
30-Jul-18CAL5309CADRegular30009028579310200009-003134-259-151$478,419.562
30-Jul-18CAL5309CADRegular3000902860978400009-003????????51$132,670.773
30-Jul-18CAL5309CADRegular300090286492608519-003102-917-251$6,595.751
30-Jul-18CAL5309CADRegular30009028669446400007-0030?0-006-751$54,658.504
30-Jul-18CAL5309CADRegular3000902871900009-003122-204-151$3,785.001
30-Jul-18CAL5309CADRegular300090287397700009-003147-274-551$642.001
30-Jul-18CAL5309CADRegular3000902877253900009-003?09-602-351$2,305.857
30-Jul-18CAL5309CADRegular3000902885253900009-003109-686-651$350.202
30-Jul-18CAL5309CADRegular3000902888253900009-003??3-888-851$36.251
30-Jul-18CAL5309CADRegular3000902890253900009-003129-531-051$30.001
30-Jul-18CAL5309CADRegular3000902892253900009-003131-609-051$150.001
30-Jul-18CAL5309CADRegular3000902894253900009-003131-608-251$150.001
30-Jul-18CAL5309CADRegular3000902896253900009-003*09-602-351$1,636.001
30-Jul-18CAL5309CADRegular3000902898253900009-003109-686-651$3,371.111

<colgroup><col span="2"><col span="3"><col><col span="3"><col><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
There's only a problem with some cells having wildcard values.
Click to expand...
Can you explain exactly what you want to happen with these?

In this first part of your original code, you have it changing "*" to "#" and changing "?" to "/".
But later in the same code, you seem to be changing it back, changing "/" back to "?", and changing "#" back to "*".

Was this intentional? Are you only changing the values long enough to build the strings, and then changing them back?
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Saveas newwb, close new wb, delete old wb
Replies
8
Views
168
eiloken
E
P
  • Question
Help with Vba Code
Replies
3
Views
159
Coyotex3
C
L
  • Question
Clean Text - Remove Repeat Line Breaks
Replies
4
Views
165
lneidorf
L
T
  • Question
ActiveSheet. Paste error
Replies
1
Views
34
RoryA
RoryA
S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
121
Scifo
S

Forum statistics

Threads
1,214,918
Messages
6,122,257
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top