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
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
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
@Ford
Thanks for the heads up !...(y)
 
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

L
  • Question
Clean Text - Remove Repeat Line Breaks
Replies
4
Views
213
lneidorf
L
M
  • Question
Saveas newwb, close new wb, delete old wb
Replies
8
Views
222
eiloken
E
S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
134
Scifo
S
F
  • Question
find and replace only within selection
Replies
3
Views
512
Fluff
Fluff
R
  • Question
Replace links after moving worksheets from one workbook to another.
Replies
2
Views
135
RockandGrohl
R

Forum statistics

Threads
1,215,473
Messages
6,125,020
Members
449,203
Latest member
tungnmqn90

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