Home » excel » Performance issues when copying the first N columns of table A to table B using Excel VBA

Performance issues when copying the first N columns of table A to table B using Excel VBA

Posted by: admin May 14, 2020 Leave a comment

Questions:

Context

I have Aand B tables where A has m columns, while B has n columns. Tables share the first columnCount columns. I need to copy data in columnCount columns from B to A.

I have no control on the structure of tables A and B.

Problem

My code is working, however I have performance issues. Indeed, if A has 730 lines (and 182 columns), and B has 470 lines (and 61 columns), and if I need to copy the content of the first 25 columns, it currently takes ~8 minutes to achieve the copy (~1 sec per line.)

Question

How can I modify my code / algorithm in order to speed up the copy ?

My code

' prior to executing the code, calculation, screen updating, animations, events 
' and alerts areturned off
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableAnimations = False
.EnableEvents = False
.DisplayAlerts = False


' creates a sub range of a range keeping only the first columnCount columns 
' of the original range
Function subRange(r As Range, columnCount As Integer) As Range
    Set subRange = r.Resize(1, columnCount)
End Function

' adds data of the first columnCount columns of a sourceTableName to a targetTableName
Public Sub addDataToTable(targetWkbook As Workbook, targetSheetName, _
                targetTableName As String, sourceWkbook As Workbook, _
                sourceSheetName As String, sourceTableName As String, _
                columnCount As Integer)
    Dim table As ListObject
    Set table = sourceWkbook.Sheets(sourceSheetName).ListObjects(sourceTableName)

    Dim currentRow As ListRow
    For Each currentRow In table.ListRows
        addDataRow targetWkbook, targetSheetName, targetTableName, _
                 subRange(currentRow.Range, columnCount), columnCount
    Next
End Sub

' adds a data row to a table, only filling the first columnCount columns
Sub addDataRow(wkbook As Workbook, sheetName, tableName As String, NewData As Range, _
               columnCount As Integer)
    Dim table As ListObject
    Set table = wkbook.Sheets(sheetName).ListObjects(tableName)

    Dim lastRow As Range

    'First check if the last table row is empty; if not, add a row
    If table.ListRows.Count > 0 Then
        Set lastRow = subRange(table.ListRows(table.ListRows.Count).Range, columnCount)
        If Application.CountBlank(lastRow) < lastRow.Columns.Count Then
            table.ListRows.Add
        End If
    End If

    'Copy NewData to new table row only filling columnCount columns 
    Set lastRow = subRange(table.ListRows(table.ListRows.Count).Range, columnCount)
    lastRow.Value2 = NewData.Value2
End Sub
How to&Answers:

As one of the comments states, your procedure is overly complicated and passing a lot of variables back and forth. I consolidated your procedure into one (it’s simple enough to not be split up into three separate procedures anyway):

Public Sub addDataToTable(targetWkbook As Workbook, targetSheetName As String, targetTableName As String, sourceWkbook As Workbook, sourceSheetName As String, sourceTableName As String, columnCount As Integer)

Dim table As ListObject
Set table = sourceWkbook.Sheets(sourceSheetName).ListObjects(sourceTableName)

Dim target_table As ListObject
Set target_table = targetWkbook.Sheets(targetSheetName).ListObjects(targetTableName)

Dim currentRow As ListRow
Dim lastrow As Range, NewData As Range
Dim lastEmpty As Boolean

lastEmpty = True
Set lastrow = target_table.ListRows(target_table.ListRows.Count).Range.Resize(1, columnCount)
If target_table.ListRows.Count > 0 And Application.CountBlank(lastrow) < lastrow.Columns.Count Then lastEmpty = False


For Each currentRow In table.ListRows
    Set NewData = currentRow.Range.Resize(1, columnCount)

    If Not lastEmpty Then
        target_table.ListRows.Add
    Else
        lastEmpty = False
    End If

    Set lastrow = target_table.ListRows(target_table.ListRows.Count).Range.Resize(1, columnCount)

    lastrow.Value2 = NewData.Value2
Next

End Sub

You also don’t need a separate function that essentially performs .Resize, just use .Resize in the first place. Also, you only need to check if the lastrow is empty once, after that you keep writing into the lastrow so it will never be empty. Try the code above and see how it handles your data.