Calling a macro through another spreadsheet takes forever!

Hi,

I am facing the following problem. I have setup a macro in a file and, with slight changes, replicated this for 4 different files. So each workbook has the same macro pretty much.

Two of the workbooks refer to the same "line" and each one works on a different "direction" (south/north for example).

What I did, for matter of convenience is to create another workbook and place some nice buttons that when you click one of them it will open two of the workbooks and run the macro that is included inside them.

The problem is, this takes forever!! When I open each workbook individually and run their macros they take a reasonable amount of time, whenever I attempt to open them through another workbook and call the macros it takes forever!. I tried calling only one workbook and running 1 macro but it still takes much longer than opening the file manually and running the macro manually from within the file.

Any ideas why that happens? I can post the code if needed but it's nothing special, just opening the xls and running the macro.

Ok, this is the code that opens and calls the macro from another workbook. It first copies tha values of two cells from the ConsoleWorkbook to the opened workbook, runs the macro and copy/pastes-special-values-only a worksheet from the opened workbook to the ConsoleWorkbook.

Sub LTSB()

'
Application.ScreenUpdating = False


Application.DisplayAlerts = False
    ChDir _
        "Finished Lines\Final Versions"
    Workbooks.Open Filename:= _
        "Finished Lines\Final Versions\workbook1.xls"
    ActiveWindow.SmallScroll ToRight:=5
    
    
    
    
    ' Set Date
    Windows("workbook1.xls").Activate
    Range("M5").Select
    ActiveCell.FormulaR1C1 = "='[consoleworkbook.xls]Sheet1'!R6C6"
    Range("M6").Select
    ActiveCell.FormulaR1C1 = "='[consoleworkbook.xls]Sheet1'!R7C6"
    Range("M7").Select
    Windows("workbook1.xls").Activate
    
    Application.Run _
        "workbook1.xls!Update_Dwell_Time_Data"
    Sheets("sheet1").Select
    Sheets("sheet1").Name = "League Board"
    
            
    Windows("workbook1.xls").Activate
    Cells.Select
    Selection.Copy
    Windows("workbook1.xls").Activate
    Worksheets.Add().Name = "League Board"
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    
    
    'Sheets("League Board").Copy After:=Workbooks("workbook1.xls").Sheets(1)
    'Cells.Select
    'Range("F1").Activate
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
    'Range("N3").Select
    'ActiveSheet.Shapes("Picture 3").Select
    'Selection.Delete
    Windows("workbook1.xls").Close
    Sheets("Sheet1").Select
    
    
Application.ScreenUpdating = True


Application.DisplayAlerts = True
End Sub

Now the macro tha runs on the opened workbook (and does the calculations)
is pretty big. I'll put here first the 2 main calculation modules and if that's not enough information I'll put the main body (grab data from sql) as well.

create and delete worksheet

Sub ClearData()

SettingsSheet = "Settings"
Dim sh As Worksheet, flg As Boolean

' Stop messages popping up requiring you to click on yes/no/delete etc.
Application.ScreenUpdating = False


Application.DisplayAlerts = False


' Delete all sheets starting with "Data_" if they exist
For Each sh In Worksheets

If sh.Name Like "Data_*" Then flg = True: Exit For
Next
If flg = True Then

For f = 1 To 50
delsheets = "Data_" & Worksheets(SettingsSheet).Cells(16 + f - 1, 10)

Worksheets(delsheets).Delete

Next f

Else

End If

' Create the worksheets 

For i = 1 To 50
   
    
Worksheets.Add(After:=Worksheets("Data")).Name = "Data_" & Worksheets(SettingsSheet).Cells(16 + i - 1, 10)

' Add column headers to the worksheets
setupsheets = "Data_" & Worksheets(SettingsSheet).Cells(16 + i - 1, 10)
      
    Sheets("Data").Select
    Range("A1:H1000").Select
    Selection.Copy
    
    Sheets(setupsheets).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
    Range("A2:H1000").Select
    Selection.Clear
    Columns("A:H").Select
    Columns("A:H").EntireColumn.AutoFit
    
 
Next i


' Reinstate the message popups

Application.ScreenUpdating = True

  
End Sub

and this one does claculations (array formulas)

Sub ConstructLeagueBoard()

Worksheets("League Board").Select
SettingsSheet = "Settings"


For i = 1 To 50

Datasheet = "Data_" & Worksheets(SettingsSheet).Cells(16 + i - 1, 10)

Worksheets("league Board").Select
    Range("D" & (i + 10)).Select
    Selection.FormulaArray = "=AVERAGE(QUARTILE(IF(('" & Datasheet & "'!K2:K65500>0),'" & Datasheet & "'!D2:D65500),2),QUARTILE(IF(('" & Datasheet & "'!K2:K65500>0),'" & Datasheet & "'!D2:D65500),3))"
      
    Range("K" & (i + 10)).Select
   Selection.FormulaArray = "=COUNT(IF('" & Datasheet & "'!K2:K65500>0,'" & Datasheet & "'!K2:K65500))"
    

 Next i
    

    
End Sub

hi Kostas

I can't see from your code how this all ends up in the "Consol'" workbook (maybe it's in the called macro of "application.run..."?).
Anyway, I've had a go at modifying the below code to run a little smoother by removing selections & declaring variables etc but haven't tested it at all - so hopfully it works...
I have prefixed my comments with "###".

Option Explicit
Sub LTSB()
    Dim FileToOpen As String
    Dim NewlyOpenedFile As Workbook
    Dim ShtToModify As Worksheet
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    '### add the full file path to the front of this string (eg "C:\Documents and Settings\HP_Owner\Desktop\"
    FileToOpen = "Finished Lines\Final Versions\workbook1.xls"
    Workbooks.Open Filename:=FileToOpen
    Set NewlyOpenedFile = ActiveWorkbook
    Set ShtToModify = ActiveSheet
    ' Set Date
    With ShtToModify
        .Range("M5").FormulaR1C1 = "='[consoleworkbook.xls]Sheet1'!R6C6"
        .Range("M6").FormulaR1C1 = "='[consoleworkbook.xls]Sheet1'!R7C6"
        .Range("M7").Select
    End With
    Application.Run _
            "workbook1.xls!Update_Dwell_Time_Data"
    Sheets("sheet1").Name = "League Board"
    '### I've made an assumption here about which is the right sheet _
     (w/o knowing what the "update_Dwell_Time_Data" macro is doing & I think my assumption is wrong!
    With ShtToModify.Range(Cells(1, 1), LastCell(ShtToModify))
        .Copy
        NewlyOpenedFile.Activate
        '### what file should this below sheet be added into?
        Worksheets.Add().Name = "League Board"
        With Range("A1")
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                   :=False, Transpose:=False
            .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False
        End With
    End With
    'Sheets("League Board").Copy After:=Workbooks("workbook1.xls").Sheets(1)
    'Cells.Select
    'Range("F1").Activate
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     '    :=False, Transpose:=False
    'Range("N3").Select
    'ActiveSheet.Shapes("Picture 3").Select
    'Selection.Delete
    '### if this is closed this way it appears that nothing gets saved?????????????
    Windows("workbook1.xls").Close
    Sheets("Sheet1").Select
    'free memory
    Set NewlyOpenedFile = Nothing
    Set ShtToModify = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
Sub ClearData()
'Now the macro tha runs on the opened workbook (and does the calculations)
'is pretty big. I'll put here first the 2 main calculation modules and if that's not enough information I'll put the main body (grab data from sql) as well.
'create and delete worksheet
    Dim SettingsSheet As String
'    Dim sh As Worksheet, flg As Boolean
    Dim f As Long, i As Long
    Dim delsheets As String
    Dim setupsheets As Worksheet
    SettingsSheet = "Settings"
    ' Stop messages popping up requiring you to click on yes/no/delete etc.
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    ' Delete all sheets starting with "Data_" if they exist
    '### can this be changed from...
    'For Each sh In Worksheets
    'If sh.Name Like "Data_*" Then flg = True: Exit For
    'Next
    'If flg = True Then
    'For f = 1 To 50
    'delsheets = "Data_" & Worksheets(SettingsSheet).Cells(16 + f - 1, 10)
    'Worksheets(delsheets).Delete
    'Next f
    'Else
    'End If
    '### to be...
    For f = 1 To 50
        delsheets = "Data_" & Worksheets(SettingsSheet).Cells(15 + f, 10).Value
        On Error Resume Next    'in case the sheet doesn't exist
        Worksheets(delsheets).Delete
        On Error GoTo 0
    Next f
    ' Create the worksheets
    For i = 1 To 50
        Worksheets.Add(After:=Worksheets("Data")).Name = "Data_" & Worksheets(SettingsSheet).Cells(15 + i, 10)
        ' Add column headers to the worksheets
        Set setupsheets = ActiveWorkbook.Worksheets("Data_" & Worksheets(SettingsSheet).Cells(15 + i, 10))
        '### why paste special when it seems that you are pasting everything & then delete all but the headers?
        '    Sheets("Data").Range("A1:H1000").Copy
        '    Sheets(setupsheets).Select
        '    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
             False, Transpose:=False
        '    Range("A2:H1000").Clear
        '    Columns("A:H").EntireColumn.AutoFit
        '### this may be quicker...
        With setupsheets.Range("a1:h1")
            .Value = Sheets("Data").Range("A1:H1").Value
            ''###if formatting is needed you can uncomment the following 2 lines of code
            '        Sheets("Data").Range("A1:H1000").Copy
            '        .Resize(1000, .Columns.Count).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:= _
                     False, Transpose:=False
            .EntireColumn.AutoFit
        End With
    Next i
    ' free memory etc
    Set setupsheets = Nothing
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
    End With
End Sub
Sub ConstructLeagueBoard()
'and this one does claculations (array formulas)
    Dim SettingsSheet As String
    Dim datasheet As String
    Dim i As Long
    Dim LastRow As Long
    Worksheets("League Board").Select
    SettingsSheet = "Settings"
    For i = 1 To 50
        datasheet = "Data_" & Worksheets(SettingsSheet).Cells(15 + i, 10).Value
        '### referencing 65 thousand rows in an array is likely to slow your computer down...
        '###can you resize the reference accurately?
        '###eg instead of...
        'LastRow = 65500
        '### can it be...
        LastRow = LastCell(Worksheets("league Board")).Row
        With Worksheets("league Board")
            .Range("D" & (i + 10)).FormulaArray = "=AVERAGE(QUARTILE(IF(('" & datasheet & "'!K2:K" & LastRow & ">0),'" & datasheet & "'!D2:D" & LastRow & "),2),QUARTILE(IF(('" & datasheet & "'!K2:K" & LastRow & ">0),'" & datasheet & "'!D2:D" & LastRow & "),3))"
            .Range("K" & (i + 10)).FormulaArray = "=COUNT(IF('" & datasheet & "'!K2:K" & LastRow & ">0,'" & datasheet & "'!K2:K" & LastRow & "))"
        End With
    Next i
End Sub
Function LastCell(ws As Worksheet) As Range
    Dim LastRow As Long
    Dim LastCol As Long
    ' Error-handling is here in case there is not any data in the worksheet
    On Error Resume Next
    With ws
        ' Find the last real row
        LastRow = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByRows).Row
        ' Find the last real column
        LastCol = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByColumns).Column
    End With
    ' Finally, initialize a Range object variable for the last populated row.
    Set LastCell = ws.Cells(LastRow, LastCol)
End Function

Even if this code doesn't work in its entirety it should give you plenty of ideas on how to optimise your working code - Goodluck!

hth
Rob

You should avoid selecting and never work on all cells just the used ranged

http://msdn.microsoft.com/en-us/libr...ffice.10).aspx

VBA Noob

Originally Posted by VBA Noob

You should avoid selecting and never work on all cells just the used ranged

http://msdn.microsoft.com/en-us/libr...ffice.10).aspx

VBA Noob

Hi,

I am not sure to which part you are referring exactly but I assume that you mean where I create a worksheet and then copy paste all the cells from another workbook-worksheet to the master newly created worksheet.

This shouldn't be causing the delay though as it happens at the end and the way it looks like when I run the macro is that there is a long pause at the beginning and then it starts working. In short, the copy/pasting of the cells doesn't see (and can't see why it should) cause the delay.

Originally Posted by excelmarksway

A suggestion or two:

Maybe have a Master workbook that has the macros and no macros in the other workbooks.

I notice you ChDir at some stage. Do you ChDir to the original location?

I did not see at any stage where the workbooks are saved.

- - excelmarksway

Hi,

Thanks for the feedback. I do change the directory to open the workbooks with the macro that is to be run (that actually does the data grabbing etc). I don't save the workbook at all, I just use the master workbook to open a series of others, run the macros inside them and then copy/paste the result worksheets back to the master one. I don't save anything at the moment.

Still that shouldn't be delaying anything, should it?