help needed to speed up macro

P

peltron

New Member
Joined
Jul 13, 2016
Messages
20
Hi everyone,

I'm not an expert at VBA and normally use codes written by others online/ in this forum. I have the following macro for my workbook and I will execute this every time I paste new data into my workbook.

The problem is, the data involved is big and can be up to 90000+ rows. The file is around 20Mb and so far, I still don't know how long this macro will take me. Everytime I automate the macro, excel stops responding.

I hope for someone to help me shorten/ speed up the macro if possible!

Code: 
Sub APAC()



    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
   


    'Delete rows which contain blank cells in column E


    Sheets("Data").Select
    On Error Resume Next
    Range("E1:E100000").Select
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete


    ' Replace countries with short notations
    Columns("C:C").Select
    Selection.Replace What:="Australia", Replacement:="AUS", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="CHINA", Replacement:="CHN", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="HONG KONG", Replacement:="HKG", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Indonesia Distrib.", Replacement:="IDN", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="JAPAN", Replacement:="JPN", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="KOREA", Replacement:="KOR", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="MyanmarCambodiaLaos", Replacement:="MCL", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Malaysia", Replacement:="MYS", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="New Zealand", Replacement:="NZL", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="PHILIPPINES", Replacement:="PHL", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="SINGAPORE", Replacement:="SGP", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="TAIWAN", Replacement:="TWN", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="THAILAND", Replacement:="THA", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="VIETNAM", Replacement:="VNM", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
 




   'Sort Data into CN, Active, Basic
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=5, Criteria1:="BASIC"
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=13, Criteria1:="CN"
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=14, Criteria1:= _
        "Active"




    'Sort Data by ascending profits
    ActiveWorkbook.Worksheets("Data").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").AutoFilter.Sort.SortFields.Add Key _
        :=Range("R1:R92077"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    
    Sheets("Data").Range("A:R").Copy Destination:=Sheets("Target").Range("A:R")




    'Clear columns S to V
    Columns("S:V").Select
    Selection.ClearContents
    
 
    'Input curve formulas
    Sheets("Target").Select
    Range("S1").Value = "%"
    Range("S2").Value = "=IF(COUNT(R2C15:RC15)<R4C25,""10%"",IF(COUNT(R2C15:RC15)<R7C25,""20%"",IF(COUNT(R2C15:RC15)<R10C25, ""30%"",0)))"
    Range("T2").Value = "1"
    Range("U1").Value = "%"
    Range("U2").Value = "=RC[-1]/COUNT(C[-6])"
    Range("V1").Value = "Cumulative Profit %"
    Range("V2").Value = "=SUM(R2C[-4]:RC18)/R3C24"


    'Autofill columns S to V, using column R as a ref
    Sheets("Target").Select
    Range("S2:V2").AutoFill Destination:=Range("S2:V" & Range("R" & Rows.Count).End(xlUp).Row)


   
   'Refresh all pivot tables
    ActiveWorkbook.RefreshAll
    


    Sheets("Summary").Select




    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.DisplayAlerts = True


    End Sub
 
Sort by date Sort by votes
Try this ....Untested

Code: 
Sub APAC()

Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long

    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
   


    'Delete rows which contain blank cells in column E

    On Error Resume Next

    Sheets("Data").Range("E1:E100000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

fndList = Array("Australia", "CHINA", "HONG KONG", "Indonesia Distrib", "JAPAN", "KOREA", "MyanmarCambodiaLaos", "Malaysia", "New Zealand", "PHILIPPINES", "SINGAPORE", "TAIWAN", "THAILAND", "VIETNAM")
rplcList = Array("AUS", "CHN", "HKG", "IDN", "JPN", "KOR", "MCL", "MYS", "NZL", "PHL", "SGP", "TWN", "THA", "VNM")

    ' Replace countries with short notations
    For x = LBound(fndList) To UBound(fndList)
        Columns("C:C").Replace What:=fndList(x), Replacement:=rplcList(x), LookAt:=xlPart, SearchOrder:=xlByRows
  
  Next x


   'Sort Data into CN, Active, Basic
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=5, Criteria1:="BASIC"
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=13, Criteria1:="CN"
    ActiveSheet.Range("$A$1:$X$92077").AutoFilter Field:=14, Criteria1:= _
        "Active"




    'Sort Data by ascending profits
    ActiveWorkbook.Worksheets("Data").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").AutoFilter.Sort.SortFields.Add Key _
        :=Range("R1:R92077"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    
    Sheets("Data").Range("A1:R100000").Copy Destination:=Sheets("Target").Range("A1:R100000")




    'Clear columns S to V
    Columns("S:V").ClearContents
    
 
    'Input curve formulas
    With Sheets("Target")
    .Range("S1").Value = "%"
    .Range("S2").Value = "=IF(COUNT(R2C15:RC15)"
 
Upvote 0
Thank you for helping me to shorten the macro. The edited part does what it's supposed to do. Running it on my 90000 rows have made excel stopped working again
 
Upvote 0
Try replacing this

Code: 
For x = LBound(fndList) To UBound(fndList)
        Columns("C:C").Replace What:=fndList(x), Replacement:=rplcList(x), LookAt:=xlPart, SearchOrder:=xlByRows
  Next x

WITH

Code: 
For x = LBound(fndList) To UBound(fndList)
        [color=red]Range("C1:C92077")[/color].Replace What:=fndList(x), Replacement:=rplcList(x), LookAt:=xlPart, SearchOrder:=xlByRows
   Next x
 
Last edited:
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
193
vancher19
V
L
  • Question Question
How to loop to find and replace with the specific cells
Replies
2
Views
432
Linda Lo
L
J
  • Solved
Assistance with excel macro
Replies
3
Views
301
dreid1011
dreid1011
N
  • Question Question
Not understanding loop in vba
Replies
7
Views
367
jolivanes
jolivanes
L
  • Locked
  • Question Question
Macros and protecting a cell
Replies
5
Views
189
Fluff
Fluff

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