make macro faster

Question

Dear forum participants,

Finally after 2 weeks working on a macro I finished it!!! But i think it can be faster, becasue it takes 2,5 minutes for the macro to complete the task.
Below is the macro where the bold,  italic and underlined part is the section that causes the slowdown. Furtermore I think i have to declare some constants or maybe something else:

Sub uploadready()

 

Dim cell As Range

Dim lngRow As Long

 

    With Range("I2", Cells(Rows.Count, "I").End(xlUp)).Offset(0, 1)

        .FormulaR1C1 = _

                "=TEXT(DATE(YEAR(RC[-1]),MONTH(RC[-1]),DAY(RC[-1])),""jjjjmmdd"")"

                End With

               

    Columns("J:J").Select

    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Range("I1").Select

    Application.CutCopyMode = False

    Selection.Cut

    Range("J1").Select

    ActiveSheet.Paste

    Columns("J:J").Select

    Selection.NumberFormat = "@"

    Columns("I:I").Select

    Selection.Delete Shift:=xlToLeft

   

   

        Columns("A:H").Select

    Range("H1").Activate

    Selection.NumberFormat = "General"

    Columns("G:H").Select

    Range("H1").Activate

    Selection.Delete Shift:=xlToLeft

  

    Columns("C:C").Select

    Selection.Delete Shift:=xlToLeft

 

    Cells.Replace What:="warrant", Replacement:="Equity", LookAt:=xlPart, _

        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

    Cells.Replace What:="right", Replacement:="Equity", LookAt:=xlPart, _

        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

    Range("A1").Select

   

 

For lngRow = 4500 To 1 Step -1

        If ActiveSheet.Cells(lngRow, 2).Value = "" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 2).Value = "ALM" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 2).Value = "FX forward" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 2).Value = "Future" Then

        ActiveSheet.Rows(lngRow).Delete

        End If

Next

 

 

For lngRow = 4500 To 1 Step -1

        If ActiveSheet.Cells(lngRow, 1).Value = "EQ GTAA" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "EUR TAA" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "JP TAA" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "PAC TAA" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "SS UK" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "SS US" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "SS EM" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "PICTET" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "US TAA" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "MS EM" Then

        ActiveSheet.Rows(lngRow).Delete

        ElseIf ActiveSheet.Cells(lngRow, 1).Value = "JPM EM" Then

        ActiveSheet.Rows(lngRow).Delete

        End If

 Next

 

 

   For Each cell In ActiveSheet.Range("B1:B4700")

        If cell.Value = "Cash bucket" Then

             cell.Offset(0, 1).FormulaR1C1 = "=RIGHT(RC[1],3)&"" ""&""Curncy"""

        End If

      Next cell

 

    Columns("F:F").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("F2").Select

    With Range("E2", Cells(Rows.Count, "E").End(xlUp)).Offset(0, 1)

        .FormulaR1C1 = _

                "=ROUND(RC[-1],0)"

                End With

    Columns("F:F").Select

 

    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Range("E1").Select

    Application.CutCopyMode = False

    Selection.Cut

    Range("F1").Select

    ActiveSheet.Paste

    Columns("E:E").Select

    Selection.Delete Shift:=xlToLeft

    Columns("B:B").Select

    Selection.Delete Shift:=xlToLeft

    Columns("A:A").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("A1").Select

    ActiveCell.FormulaR1C1 = "Region"

    Range("A1").Select

 

 

   For Each cell In ActiveSheet.Range("B1:B4700")

        If cell.Value = "AB JPN" Then

             cell.Offset(0, -1).FormulaR1C1 = "Japan"

        ElseIf cell.Value = "AB UK" Then

            cell.Offset(0, -1).FormulaR1C1 = "UK"

        ElseIf cell.Value = "AXA" Then

            cell.Offset(0, -1).FormulaR1C1 = "Europe"

        ElseIf cell.Value = "DAIWA" Then

            cell.Offset(0, -1).FormulaR1C1 = "Japan"

        ElseIf cell.Value = "EUR INT" Then

            cell.Offset(0, -1).FormulaR1C1 = "Europe"

        ElseIf cell.Value = "GS" Then

            cell.Offset(0, -1).FormulaR1C1 = "Europe"

        ElseIf cell.Value = "INTECH" Then

            cell.Offset(0, -1).FormulaR1C1 = "US"

        ElseIf cell.Value = "JPM EUR" Then

            cell.Offset(0, -1).FormulaR1C1 = "Europe"

        ElseIf cell.Value = "JPM PAC" Then

            cell.Offset(0, -1).FormulaR1C1 = "Pacific"

        ElseIf cell.Value = "LLOYD" Then

            cell.Offset(0, -1).FormulaR1C1 = "Pacific"

        ElseIf cell.Value = "TN UK" Then

            cell.Offset(0, -1).FormulaR1C1 = "UK"

        ElseIf cell.Value = "TROWEP" Then

            cell.Offset(0, -1).FormulaR1C1 = "US"

        ElseIf cell.Value = "TROWEPLCG" Then

            cell.Offset(0, -1).FormulaR1C1 = "US"

        End If

      Next cell

 

 

    Columns("A:E").Select

    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

       Range("A1").Select

    Application.CutCopyMode = False

  

End Sub

Thank you all in advance!
Mahsun

Answer 1

Two Steps:

1, add application.screenupdating=false
2, record filter actions in VBA, change a little bit, it will definitely run much faster than "if ... then ..."

I answer briefly, but it will help. Trust me.

---

Li Xiang
UNL Actuarial Science Student
Good at Access/ Excel/ SAS /SQL
SAS is torturing me~~~Still looking for a summer intern~~~Anyone wants to hire me????~~~~

Answer 2

Hi Mahsun

I was surprised at your long code. 

You're working at a finance company.

As you said, you can make it faster as long as you make it shorter.

First, Plz Add the following code after the variables declation

    With Application

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

        .EnableEvents = False

    End With

And  Add the following before End Sub

    With Application

        .ScreenUpdating = True

        .Calculation = xlCalculationAutomatic

        .EnableEvents = True

    End With

These codes are related to screen rendering, calculation and events

I saw you have many loops deleting rows. the deleting requires screen rendering.

 .ScreenUpdating = False makes it disable.

you need to update screen after finishing your job.

and I'd like say one more thing.

I saw you used many SELECT and ACTIVATE methods. They make the code slower.

You can reduce it as following.

before:

Columns("A:E").Select

Selection.Copy

after:

Columns("A:E").Copy

There are many codes to be optimized that I could not explain because I can't see your workbook. 

HTH

SJOO

---

the best time to plant a tree was twenty years ago. the second best time, is today (Chinese proverb) sjoo.kwak at gmail.com