Excel VBA宏优化请求：配电系统杆塔物料统计提速

我在电力公司负责配电系统建设，系统采用包含预定义物料的标准电气结构，每个结构有唯一标识。现有Excel工作簿包含3个工作表：

• WORKSHEET1：由AutoCAD生成的杆塔-对应结构表（示例：杆塔1含结构A、B、C；杆塔2含结构B、D、F等）
• WORKSHEET2：各结构的标准物料数量表
• WORKSHEET3：各杆塔的物料汇总表

当前使用VBA宏迭代WORKSHEET1中的结构，查询WORKSHEET2的物料数据并求和至WORKSHEET3，但在100+杆塔、500+结构的场景下，因频繁读写工作表耗时长达8分钟。希望通过数组替代Range的方式优化代码，提升运行效率。

现有代码如下：

Sub Iteration()
    Dim sourcews As Worksheet
    Dim targetws As Worksheet
 
    Dim rowCount As Long
    Dim colCount As Long
    Dim r As Long, c As Long
    Dim cellValue As Integer
    
    
    Set sourcews = ThisWorkbook.Sheets("WORKSHEET1") 
    
    
    rowCount = sourcews.Cells(sourcews.Rows.Count, 1).End(xlUp).Row 
    colCount = sourcews.Cells(1, sourcews.Columns.Count).End(xlToLeft).Column 


    
    For r = 1 To rowCount
        
            For i = 1 To 25
                If sourcews.Cells(r, i + 10).Value <> "" Then
                    cellValue = Right(sourcews.Cells(r, 5).Value, Len(sourcews.Cells(r, 5).Value) - 1)
                    Call SumColumnData(cellValue, sourcews.Cells(r, 5).Value, sourcews.Cells(r, i + 10).Value)
                End If
            Next i
        
    Next r



End Sub


Sub SumColumnData(cellPost As Integer, numPost As String, estr As String)

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim headerName As String
    Dim targetHeader As String
    Dim sourceColumn As Range
    Dim targetColumn As Range
    Dim sourceHeaderCell As Range
    Dim cell As Range
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim targetHeaderCell As Range
    
    
    
    ' Set references to the sheets
    Set sourceSheet = ThisWorkbook.Sheets("WORKSHEET2") 
    Set targetSheet = ThisWorkbook.Sheets("WORKSHEET3") 

    ' Find the column with the specified header in the source sheet
        If Right(estr, 1) = "r" Then
            Set sourceHeaderCell = sourceSheet.Rows(1).Find(What:=Left(estr, Len(estr) - 1), LookIn:=xlValues, LookAt:=xlWhole)
        Else
            Set sourceHeaderCell = sourceSheet.Rows(1).Find(What:=estr, LookIn:=xlValues, LookAt:=xlWhole)
        End If
    
    
    If Not sourceHeaderCell Is Nothing Then
        ' Get the range for the column below the header
        lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, sourceHeaderCell.Column).End(xlUp).Row
        Set sourceColumn = sourceSheet.Range(sourceHeaderCell.Offset(1, 0), sourceSheet.Cells(lastRowSource, sourceHeaderCell.Column))
        
        'Find the column with the specified header in the target sheet
        If Right(estr, 1) = "r" Then
            Set targetHeaderCell = targetSheet.Range("A1").Offset(0, cellPost * 2 + 8)
        Else
            Set targetHeaderCell = targetSheet.Range("A1").Offset(0, cellPost * 2 + 7)
        End If
        
        If Not targetHeaderCell Is Nothing Then
            ' Get the range for the target column
            lastRowTarget = targetSheet.Cells(targetSheet.Rows.Count, targetHeaderCell.Column).End(xlUp).Row
            Set targetColumn = targetSheet.Range(targetHeaderCell.Offset(13, 0), targetSheet.Cells(lastRowTarget, targetHeaderCell.Column))
            
            ' Sum the values from the source column and add to the target column
            For Each cell In sourceColumn
                If IsNumeric(cell.Value) Then
                    targetSheet.Cells(cell.Row + 12, targetHeaderCell.Column).Value = targetSheet.Cells(cell.Row + 12, targetHeaderCell.Column).Value + cell.Value
                End If
            Next cell

            
        End If

    End If

End Sub

内容的提问来源于stack exchange，提问作者Geekbaggins