Consulting

Results 1 to 3 of 3

Thread: VBA Code optimization- Speed up this Macro

  1. #1
    VBAX Newbie
    Joined
    Jun 2017
    Posts
    3
    Location

    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.
     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
    Last edited by Bob Phillips; 09-21-2017 at 01:06 PM. Reason: Added code tags

  2. #2
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    You would need to post sample workbook(s) on which to test your code, also the code TM1RECALC.
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  3. #3
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •