VBA Code optimization- Speed up this Macro

Hi All,

I am new to VBA and inherited a macro powered process that tends to tie up my excel and then crashes half the time. It also doesn't work on other people computer most of the time. The code is below. Is there any way to really optimize it by taking out some "selects" or something. Please help:

the "Office_code = Sheets("Macro")" has a list of all the offices that need to be published.

Code:

---

Sub IS_Loopfile()'
'  Creates and Publishes Office Income Statement Reports'
'
    Application.Run "TM1RECALC"
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Sheets("Macro").Select
    Dim new_wbk As String
        new_wbk = "Field Income Statements - Key Accounts  - " & Sheets("Macro").Range("G2").Value & " - " & Sheets("Macro").Range("G3").Value & ".xlsm"
    Range("A4").Select
    ActiveCell.End(xlDown).Select
    Endrow = ActiveCell.Row
    Workbooks.Add
'    newdirectory = "Y:\"
'    ChDrive newdirectory
'    ChDir newdirectory
    ActiveWorkbook.SaveAs FileName:=new_wbk, FileFormat:=52
    For i = 4 To 43
        Windows("Field Income Statements - Key Accounts Controllable - New Structure v4.xlsm").Activate
        Office_code = Sheets("Macro").Range("a" & i).Value
        PriorOffice = Sheets("Macro").Range("a" & i - 1).Value
        Office_Name = Sheets("Macro").Range("b" & i).Value
        PrOffice_Name = Sheets("Macro").Range("b" & i - 1).Value
        Sheets("Income Statement").Select
        Range("A6").Value = Office_code    'change the range
        If i = 4 Then
            Sheets("Income Statement").Copy After:=Workbooks(new_wbk).Sheets(1)
        Else
            Sheets("Income Statement").Copy After:=Workbooks(new_wbk).Sheets(PrOffice_Name)
        End If
        Sheets("Income Statement").Select
        Sheets("Income Statement").Name = Office_Name
        ActiveSheet.Range("A1").Activate
    Next i
    Windows("Field Income Statements - Key Accounts Controllable - New Structure v4.xlsm").Activate
        Sheets("Macro").Copy After:=Workbooks(new_wbk).Sheets(1)
        Sheets("Macro").Select
    Windows("Field Income Statements - Key Accounts Controllable - New Structure v4.xlsm").Activate
        Sheets("Cover").Copy After:=Workbooks(new_wbk).Sheets("Macro")
        Sheets("Cover").Select
    Windows(new_wbk).Activate
    Application.Run "TM1RECALC"
    For j = 3 To 3
        Windows(new_wbk).Activate
        OfficeSheet = Sheets("Macro").Range("b" & j).Value
        Sheets(OfficeSheet).Activate
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Application.CutCopyMode = False
        ActiveSheet.Range("A1:O1,A3:O3,A6:O6,A35:O35").Select
        Selection.Merge
        ActiveSheet.Range("A1").Activate
        ActiveSheet.Range("H23").Select
    Next j
    For k = 4 To 4
        Windows(new_wbk).Activate
        OfficeSheet = Sheets("Macro").Range("b" & k).Value
        Sheets(OfficeSheet).Activate
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Application.CutCopyMode = False
        'Hide Countrywide for Countrywide
        Columns("U:AB").Select
        Range("U16").Activate
        Selection.EntireColumn.Hidden = True
        ActiveSheet.Range("A1").Activate
        ActiveSheet.Range("D17:AB17,D18:AB18,D19:AB19,D20:AB20,L23:S23,L24:S24,U23:AB23,U24:AB24").Select
        Selection.Merge
        ActiveSheet.Range("AB16").Select
        Selection.Copy
        ActiveSheet.Range("S16").Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Application.CutCopyMode = False
        ActiveSheet.Range("A1").Activate
    Next k
    For l = 5 To 43
        Windows(new_wbk).Activate
        OfficeSheet2 = Sheets("Macro").Range("b" & l).Value
        Sheets(OfficeSheet2).Activate
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Application.CutCopyMode = False
        ActiveSheet.Range("D17:AB17,D18:AB18,D19:AB19,D20:AB20,L23:S23,L24:S24,U23:AB23,U24:AB24").Select
        Selection.Merge
        ActiveSheet.Range("A1").Activate
    Next l
    Sheets("Sheet1").Delete
    Tab_Color_Change
    Sheets("Countrywide").Select 'Change to reflect a element in the loop range!
    Application.Dialogs(xlDialogSaveAs).Show
End Sub

---

You would need to post sample workbook(s) on which to test your code, also the code TM1RECALC.

Look for blocks of code like this

Code:

---

Sheets("Macro").Select
'   
 '
'
  Range("A4").Select
    ActiveCell.End(xlDown).Select
    Endrow = ActiveCell.Row

---

Think about that it is doing and you can see that this does the same thing.

Code:

---

With Sheets("Macro")
'
'
'
EndRow = .Range("A4").End(xlDown).Row

---

you have to be carwful because when you see this

Code:

---

    Sheets("Cover").Copy After:=Workbooks(new_wbk).Sheets("Macro")
    Sheets("Cover").Select

---

YOu have to know which workbook the Selected "Cover" sheet is in. Or you can specify

Code:

---

Workbooks(new_wbk).Sheets("Cover")
' or
THisWorkbook.Sheets("Cover")

---

Normally, you can just delete all

Code:

---

...Select
Selection...

---

and just insure that you leave one dot where the deletion occured. But in a case of Multiple uses of Selection with one Select

Code:

---

Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

---

It's easiest to use a With Statement

Code:

---

With Cells
.Copy
.Paste Special...
.PasteSpecial...
End With

---