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:
Sort by date Sort by votes
Joe4 said:
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?
Click to expand...


I had to change the * as otherwise when I SUMIF, Excel treats that as wildcard and sums up everything. The same is true to ? as well (and I chose to replace them with # and / respectively). I changed them back after the calculations.
 
Upvote 0

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
OK, then let's try moving that back part until after the formulas like this:
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
    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

    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
    End With

    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
Joe4 said:
OK, then let's try moving that back part until after the formulas like this:
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
    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

    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
    End With

    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
Click to expand...


That's it, you're amazing, thank you so much!!!
I will study the changes made to the codes the different times in this thread as I can definitely learn a lot from it, thanks again!!!!!!!!!!!!!!
 
Upvote 0
You are welcome.

If you have any questions about anything I did, feel free to post them here.
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question Question
US/European Date Format Updates Not Working on Macro Run
Replies
0
Views
104
vancher19
V
L
  • Question Question
How to loop to find and replace with the specific cells
Replies
2
Views
318
Linda Lo
L
Sean15
  • Question Question
Could you help improve recorded macro
2
Replies
13
Views
444
Sean15
Sean15
N
  • Question Question
Not understanding loop in vba
Replies
7
Views
299
jolivanes
jolivanes
J
  • Solved
Assistance with excel macro
Replies
3
Views
249
dreid1011
dreid1011

Forum statistics

Threads
1,223,897
Messages
6,175,271
Members
452,628
Latest member
dd2

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