copying 12 diffrent workbooks to one, any way to optimize the code and make it run faster?

Question

I need to open 12 different workbooks copy the data to 1 workbook in 12 sheets and make each range a table, any way to make the code faster than what I wrote? all workbooks are in one shared folder, mixed with different workbooks that do not need to be opened. The current run time is 20 seconds

Sub callstuff()

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
Call CurrentRegionArray("helper1", "book2.xlsx", "sheet2", "J4")
Call CurrentRegionArray("helper2", "book3.xlsx", "sheet3", "J4")
Call CurrentRegionArray("helper3", "book4.xlsx", "sheet4", "J4")
Call CurrentRegionArray("helper4", "book5.xlsx", "sheet5", "J4")
Call CurrentRegionArray("helper5", "book6.xlsx", "sheet6", "J4")
Call CurrentRegionArray("helper6", "book7.xlsx", "sheet7", "J4")
Call CurrentRegionArray("helper7", "book8.xlsx", "sheet8", "J4")
Call CurrentRegionArray("helper8", "book9.xlsx", "sheet9", "J4")
Call CurrentRegionArray("helper9", "book10.xlsx", "sheet10", "J4")
Call CurrentRegionArray("helper10", "book11.xlsx", "sheet11", "J4")
Call CurrentRegionArray("helper11", "book12.xlsx", "sheet12", "J4")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Sub CurrentRegionArray(TableName As String, WorkBookName As String, SheetName As String, RangeName As String)
    


        Dim strPath As String
        strPath = "/Users/dimagoroh/Desktop/nastia stuff "
        Application.Workbooks.Open (strPath & "/" & WorkBookName)

'copy range to array and copy that array to diffrent sheet
    With Workbooks("book1.xlsm").Worksheets(SheetName).Range(RangeName)
         oarray = Workbooks(WorkBookName).Worksheets("sheet1").ListObjects("leavetracker").DataBodyRange.Value
        .CurrentRegion.Clear
        .Resize(UBound(oarray, 1), UBound(oarray, 2)) = oarray
    End With


'Seting range as table and giving it a name

Dim rngTable As Range

    With Workbooks("book1.xlsm").Worksheets(SheetName)
            Set rngTable = .Range(RangeName).CurrentRegion
            .ListObjects.Add(xlSrcRange, rngTable, , xlYes).Name = TableName
    End With
    
Workbooks(WorkBookName).Close
Erase oarray

End Sub

How fast does it execute now? – Samuel Everson Sep 06 '21 at 03:00 — Samuel Everson, Sep 06 '21 at 03:00
Perhaps better asked on the Code Review Stack. – Solar Mike Sep 06 '21 at 04:52 — Solar Mike, Sep 06 '21 at 04:52
it executes in 20 seconds – dima gorokh Sep 06 '21 at 05:57 — dima gorokh, Sep 06 '21 at 05:57

score 0 · Accepted Answer · answered Sep 06 '21 at 10:32

Update Tables

It is assumed that all source workbooks contain a worksheet named Sheet1 containing a table named LeaveTracker.
It is assumed that the data in destination (starting in J4) is already in a table and that you are trying to update the values in each of the tables which would also mean that each of the source and their respective destination tables has the same headers and the same number of columns.
I found that the main issue with your code and my initial code is that it will delete the existing tables in destination and break any references from other cells to them hence a less intrusive solution was needed.
The code will resize the destination table to the size of the source table, copy the values and delete any values below if source has fewer rows than destination preserving any references to the destination table.

The Code

Option Explicit

Sub UpdateTables()
    On Error GoTo ClearError ' to at least reset 'Calculation'.
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    UpdateTable "Book2.xlsx", "Sheet2", "J4"
    UpdateTable "Book3.xlsx", "Sheet3", "J4"
    UpdateTable "Book4.xlsx", "Sheet4", "J4"
    UpdateTable "Book5.xlsx", "Sheet5", "J4"
    UpdateTable "Book6.xlsx", "Sheet6", "J4"
    UpdateTable "Book7.xlsx", "Sheet7", "J4"
    UpdateTable "Book8.xlsx", "Sheet8", "J4"
    UpdateTable "Book9.xlsx", "Sheet9", "J4"
    UpdateTable "Book10.xlsx", "Sheet10", "J4"
    UpdateTable "Book11.xlsx", "Sheet11", "J4"
    UpdateTable "Book12.xlsx", "Sheet12", "J4"
    
SafeExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
    Resume SafeExit
End Sub

Sub UpdateTable( _
        ByVal SourceWorkbookName As String, _
        ByVal DestinationWorksheetName As String, _
        ByVal DestinationFirstCellAddress As String)
    
    Const swbPath As String = "/Users/dimagoroh/Desktop/nastia stuff/"
    Const swsName As String = "Sheet1"
    Const stblName As String = "LeaveTracker"
    Const dwbName As String = "Book1.xlsm"
    
    Dim sFilePath As String: sFilePath = swbPath & SourceWorkbookName
    If Len(Dir(sFilePath)) = 0 Then Exit Sub
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
    Dim stbl As ListObject: Set stbl = sws.ListObjects(stblName)
    Dim srg As Range: Set srg = stbl.DataBodyRange
    Dim srCount As Long: srCount = srg.Rows.Count
    
    Dim dwb As Workbook: Set dwb = Workbooks(dwbName)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DestinationWorksheetName)
    Dim dfCell As Range: Set dfCell = dws.Range(DestinationFirstCellAddress)
    Dim dtbl As ListObject: Set dtbl = dfCell.ListObject
    Dim drg As Range: Set drg = dtbl.DataBodyRange
    Dim drCount As Long: drCount = drg.Rows.Count
    dtbl.Resize dws.Range(dfCell, _
        dfCell.Resize(srCount + 1, srg.Columns.Count)) ' + 1 for header row
    dtbl.DataBodyRange.Value = stbl.DataBodyRange.Value
    If drCount > srCount Then
        Dim crg As Range
        Set crg = drg.Resize(drCount - srCount).Offset(srCount)
        crg.Clear
    End If
    swb.Close SaveChanges:=False
    
End Sub

Your Code Issues

The Call keyword is considered deprecated i.e. instead of Call SumFunction(Arg1, Arg2,...) use
SomeFunction Arg1, Arg2,... (without the parentheses).
Similarly, you wrote Application.Workbooks.Open (strPath & "/" & WorkBookName) where you can discard Application. but more importantly you should discard the parentheses i.e. use either
Workbooks.Open strPath & "/" & WorkBookName without, or
Dim wb As Workbook: Set wb = Workbooks.Open(strPath & "/" & WorkBookName) with the parentheses. Note in your line, how VBA has 'inserted' a space between ...Open and (... 'indicating' that it is incorrect (wrong).
If your code fails, calculation will stay manual hence as a rule of thumb, you should implement some error handling when turning it off.
If your code is in the destination workbook, you should most definitely use
Set dwb = ThisWorkbook instead of
Set dwb = Workbooks(dwbName) and remove or out-comment the line Const dwbName....
Related to writing the values of a range to an array, if srg is a range then srg.Value is (already) a 2D one-based array containing the values of the range. The following three do the same (write the values from source to destination):
```
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value

arr = srg.Value
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = arr

arr = srg.Value
dCell.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
```

My Initial Code

Sub CurrentRegionArrayDelete( _
        ByVal SourceWorkbookName As String, _
        ByVal DestinationWorksheetName As String, _
        ByVal DestinationFirstCellAddress As String)
    
    Const swbPath As String = "/Users/dimagoroh/Desktop/nastia stuff/"
    Const swsName As String = "Sheet1"
    Const stblName As String = "LeaveTracker"
    Const dwbName As String = "Book1.xlsm"
    
    Dim sFilePath As String: sFilePath = swbPath & SourceWorkbookName
    If Len(Dir(sFilePath)) = 0 Then Exit Sub
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
    Dim stbl As ListObject: Set stbl = sws.ListObjects(stblName)
    
    Dim dwb As Workbook: Set dwb = Workbooks(dwbName)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DestinationWorksheetName)
    Dim dfCell As Range: Set dfCell = dws.Range(DestinationFirstCellAddress)
    Dim dtbl As ListObject: Set dtbl = dfCell.ListObject
    Dim dtblName As String: dtblName = dtbl.Name
    dtbl.Delete
    stbl.Range.Copy dfCell
    dfCell.ListObject.Name = dtblName
    
    swb.Close SaveChanges:=False
    
End Sub

Barely Related

Sub ListTablesInThisWorkbook()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet
    Dim tbl As ListObject
    For Each ws In wb.Worksheets
        Debug.Print ws.Name
        For Each tbl In ws.ListObjects
            Debug.Print "    " & tbl.Name
        Next tbl
    Next ws
End Sub

copying 12 diffrent workbooks to one, any way to optimize the code and make it run faster?

1 Answers1

Update Tables