似乎@BigBen 是正确的，使用loTable.ListRows.Add 添加行会减慢它的速度。
更改以下代码使子例程几乎是瞬时的，而在最小工作示例中，600 行大约需要 30 秒。
原代码：
Do While loTable.ListRows.Count < lNewRowCount ' Add rows until table is the correct length
loTable.ListRows.Add
Loop
替换代码：
If loTable.ListRows.Count < lNewRowCount Then ' Add rows until table is the correct length
loTable.Resize loTable.Range.Resize(lNewRowCount + 1, loTable.HeaderRowRange.Count)
End If
如果有人感兴趣，这里是一个最小的工作示例：
Sub Test()
Dim loTable As ListObject
Dim vHeaderArray As Variant
Dim vDataArray As Variant
' Get test data
Set loTable = Table_Get("Table_1")
' Get header data
vHeaderArray = Make_HeaderArray(loTable)
' Get body data
vDataArray = Make_DataArray(loTable)
' Get table to update
Set loTable = Table_Get("Table_2")
' Output to table
'Table_ReplaceByColumn loTable, vHeaderArray, vDataArray
Table_ReplaceByColumnFast loTable, vHeaderArray, vDataArray
End Sub
Public Function Make_HeaderArray(ByVal loTable As ListObject) As Variant
Dim vHeaderArray As Variant
Dim lIndex As Long
' Build an array of headers
ReDim vHeaderArray(1 To loTable.HeaderRowRange.Count)
For lIndex = LBound(vHeaderArray) To UBound(vHeaderArray)
vHeaderArray(lIndex) = loTable.HeaderRowRange(lIndex).Value2
Next
Make_HeaderArray = vHeaderArray
End Function
Public Function Make_DataArray(ByVal loTable As ListObject) As Variant
Dim vBodyArray As Variant
Dim lIndexRow As Long
Dim lIndexCol As Long
Dim this_loRow As ListRow
'Dim this_sHeader As String
' Build an array of body data
ReDim vBodyArray(1 To loTable.ListColumns.Count, 1 To loTable.ListRows.Count)
For lIndexRow = 1 To loTable.ListRows.Count
'Set this_loRow = loTable.ListRows(lIndexRow).DataBodyRange
For lIndexCol = 1 To loTable.ListColumns.Count
'this_sHeader = vHeaderArray(lIndexCol)
vBodyArray(lIndexCol, lIndexRow) = loTable.DataBodyRange(lIndexRow, lIndexCol).Value2
Next
Next
Make_DataArray = vBodyArray
End Function
Public Sub Table_ReplaceByColumn(ByVal loTable As ListObject, ByVal vHeaderArray As Variant, ByVal vDataArray As Variant)
Dim lCounterA As Long
Dim lNewRowCount As Long
Dim rThisRange As Range
Dim this_vData As Variant
' Clear the table if there is data in it
If Not loTable.DataBodyRange Is Nothing Then
loTable.DataBodyRange.Rows.Delete ' Delete all rows in the table, but keep default data
End If
' Using the headers, check for a match then update the table
For lCounterA = LBound(vHeaderArray) To UBound(vHeaderArray)
If Table_HeaderExists(loTable.Name, vHeaderArray(lCounterA)) Then ' Does the header exist?
lNewRowCount = UBound(vDataArray, 2) - LBound(vDataArray, 2) + 1
Do While loTable.ListRows.Count < lNewRowCount ' Add rows until table is the correct length
loTable.ListRows.Add
Loop
Set rThisRange = loTable.HeaderRowRange.Cells.Item(2, loTable.ListColumns.[_Default](vHeaderArray(lCounterA)).Index) ' Get the first row of the column
Set rThisRange = rThisRange.Resize(lNewRowCount, 1) ' Expand range to fit new data
this_vData = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(vDataArray, lCounterA, 0)) ' Get correct column of data and arrange if to directly paste
rThisRange.Value = this_vData ' Paste the data in the column.
End If
Next
End Sub
Public Sub Table_ReplaceByColumnFast(ByVal loTable As ListObject, ByVal vHeaderArray As Variant, ByVal vDataArray As Variant)
Dim lCounterA As Long
Dim lNewRowCount As Long
Dim this_rRange As Range
Dim new_rRange As Range
Dim this_vData As Variant
' Clear the table if there is data in it
If Not loTable.DataBodyRange Is Nothing Then
loTable.DataBodyRange.Rows.Delete ' Delete all rows in the table, but keep default data
End If
' Using the headers, check for a match then update the table
For lCounterA = LBound(vHeaderArray) To UBound(vHeaderArray)
If Table_HeaderExists(loTable.Name, vHeaderArray(lCounterA)) Then ' Does the header exist?
lNewRowCount = UBound(vDataArray, 2) - LBound(vDataArray, 2) + 1
If loTable.ListRows.Count < lNewRowCount Then ' Add rows until table is the correct length
loTable.Resize loTable.Range.Resize(lNewRowCount + 1, loTable.HeaderRowRange.Count)
End If
Set this_rRange = loTable.HeaderRowRange.Cells.Item(2, loTable.ListColumns.[_Default](vHeaderArray(lCounterA)).Index) ' Get the first row of the column
Set this_rRange = this_rRange.Resize(lNewRowCount, 1) ' Expand range to fit new data
this_vData = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(vDataArray, lCounterA, 0)) ' Get correct column of data and arrange if to directly paste
this_rRange.Value = this_vData ' Paste the data in the column.
End If
Next
End Sub
Public Function Table_Get(ByVal sTableName As String) As Object
Dim loTable As ListObject
Dim oSheet As Object
For Each oSheet In ThisWorkbook.Worksheets ' Search through all sheets in workbook for the table
For Each loTable In oSheet.ListObjects ' Search through all tables in sheet for the table
If loTable.Name = sTableName Then ' Check this list objects name to see if it's correct
GoTo EndFor
End If
Next loTable
Next oSheet
' If we got this far, the table wasn't found.
Set Table_Get = Nothing
Exit Function
EndFor:
Set Table_Get = loTable
End Function
Public Function Table_HeaderExists(ByVal sTableName As String, ByVal sHeaderName As String) As Boolean
Dim loHeader As ListColumn
Dim loTable As ListObject
On Error GoTo DoesNotExist
Set loTable = Table_Get(sTableName)
Set loHeader = loTable.ListColumns(sHeaderName)
On Error GoTo 0
Table_HeaderExists = True
Exit Function
'Error Handler
DoesNotExist:
Err.Clear
Table_HeaderExists = False
End Function