VBA Code optimization- Speed up this Macro

[tmarinho]

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.


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

[mdmackillop]

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

[SamT]

Look for blocks of code like this
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.
With Sheets("Macro")
'
'
'
EndRow = .Range("A4").End(xlDown).Row
you have to be carwful because when you see this
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

Workbooks(new_wbk).Sheets("Cover")
' or
THisWorkbook.Sheets("Cover")
Normally, you can just delete all

...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
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

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