Excel跨工作表数据迁移宏运行缓慢，寻求性能优化方案

我有一份采用大纲分组格式的Excel文件，主ID（大纲级别1）和关联ID（大纲级别2）通过大纲分组关联。需求是将Sheet1中从A6开始的数据（前5行为通用信息无需迁移）转换为线性格式迁移到同工作簿的Export工作表：

• 原表中主ID单独一行、关联ID在下一行，新表中主ID与关联ID需在同一行
• 若存在多个关联ID，主ID需重复对应每行关联ID

现有宏功能正常，但处理500行数据需4-5分钟，寻求性能优化方案。原宏代码如下：

Private Sub Workbook_Open() 
' ' MoveRows Macro ' 
' Keyboard Shortcut: Ctrl+w

Dim lastrow As Long 
Dim lastcol As Long 
Dim i As Integer 
Dim iNewRow As Integer 
Dim ws As Worksheet 
Dim cell As Range
Dim row As Long 
Dim crtLvl As Integer 
Dim rgRow As Range 
Dim orgSelect As Range

lastrow = Sheet1.Cells(Rows.Count, 3).End(xlUp).row 
lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column

'MsgBox lastrow

'Delete all worksheets other than Sheet1 
Application.DisplayAlerts = False 
For Each ws In Worksheets 
If ws.Name <> "Sheet1" 
Then ws.Delete 
End If 
Next 
Application.DisplayAlerts = True

'Create a new worksheet 
Sheets.Add(after:=Sheet1).Name = "Export" 
With Sheets("Export") 
.Range("A1") = "ID" 
.Range("B1") = "Name" 
.Range("C1") = "Type" 
.Range("D1") = "Owner" 
.Range("E1") = "Task Status" 
.Range("F1") = "Associated Resource ID" 
.Range("G1") = "Associated Resource Name" 
.Range("H1") = "Associated Resource Type" 
.Range("I1") = "Associated Resource Owner" 
.Range("J1") = "Associated Resource Status"

.Range("A1:J1").Interior.ColorIndex = 8
End With

i = 6 
iNewRow = 2 
Dim sht As Worksheet 
Dim Lr As Long 
Dim Lc As Long 
Dim FirstCell As Range
Set sht = Worksheets("Sheet1") 
Set FirstCell = Range("A6") 
Dim inp As Integer 
Dim iFirstLevelRow As Integer

With Sheet1 
For Each cell In .Range("a6", .Cells(lastrow, lastcol)) 
'rg2c = Range(FirstCell, .Cells(i, 1).Select) 
rangeName = i & ":" & i 
rg2c = Worksheets("Sheet1").Range(rangeName)

inp = Worksheets("Sheet1").Rows(i).OutlineLevel 

If i <= lastrow Then
   If inp = 1 Then
   iFirstLevelRow = cell.row
  
        i = i + 1
 End If
  If inp = 2 Then
  .Cells(iFirstLevelRow, 1).Copy Sheets("Export").Cells(iNewRow, 1)
        .Cells(iFirstLevelRow, 2).Copy Sheets("Export").Cells(iNewRow, 2)
        .Cells(iFirstLevelRow, 3).Copy Sheets("Export").Cells(iNewRow, 3)
           .Cells(iFirstLevelRow, 4).Copy Sheets("Export").Cells(iNewRow, 4)
           .Cells(iFirstLevelRow, 5).Copy Sheets("Export").Cells(iNewRow, 5)
           .Cells(iFirstLevelRow, 6).Copy Sheets("Export").Cells(iNewRow, 6)
  .Cells(cell.row, 1).Copy Sheets("Export").Cells(iNewRow, 7)
        .Cells(cell.row, 2).Copy Sheets("Export").Cells(iNewRow, 8)
        .Cells(cell.row, 3).Copy Sheets("Export").Cells(iNewRow, 9)
         .Cells(cell.row, 4).Copy Sheets("Export").Cells(iNewRow, 10)
        i = i + 1
        iNewRow = iNewRow + 1
 End If
 End If

Next

End With

Worksheets("Export").UsedRange.EntireColumn.AutoFit
Worksheets("Export").UsedRange.EntireRow.AutoFit 
End Sub

• 禁用Excel界面交互：关闭屏幕更新、事件触发和自动计算，减少UI层面的性能开销
• 避免逐个单元格复制：改用批量数组赋值替代Copy方法，大幅提升数据读写速度
• 优化循环逻辑：从遍历所有单元格改为按行遍历处理大纲级别，直接减少循环次数
• 减少对象重复引用：提前定义并重用工作表对象，避免每次操作都重新查找工作表
• 简化冗余操作：移除未使用的变量，优化工作表删除逻辑

Private Sub Workbook_Open()
    ' MoveRows Macro
    ' Keyboard Shortcut: Ctrl+w
    
    ' 性能优化：禁用界面交互与自动计算
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim wsSource As Worksheet, wsExport As Worksheet
    Dim lastRow As Long, i As Long, newRow As Long
    Dim mainRowData As Variant, assocRowData As Variant
    Dim currentOutlineLevel As Integer
    Dim mainRow As Long
    
    ' 初始化源工作表对象
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    
    ' 删除已存在的Export表（如果有）
    On Error Resume Next
    ThisWorkbook.Worksheets("Export").Delete
    On Error GoTo 0
    
    ' 创建新的Export工作表
    Set wsExport = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsExport.Name = "Export"
    
    ' 批量设置Export表头
    With wsExport.Range("A1:J1")
        .Value = Array("ID", "Name", "Type", "Owner", "Task Status", _
                      "Associated Resource ID", "Associated Resource Name", _
                      "Associated Resource Type", "Associated Resource Owner", _
                      "Associated Resource Status")
        .Interior.ColorIndex = 8
    End With
    
    ' 获取源数据最后一行
    lastRow = wsSource.Cells(Rows.Count, 3).End(xlUp).Row
    newRow = 2
    mainRow = 0
    
    ' 按行遍历源数据（从第6行开始）
    For i = 6 To lastRow
        currentOutlineLevel = wsSource.Rows(i).OutlineLevel
        
        Select Case currentOutlineLevel
            Case 1
                ' 记录主ID行号，批量读取主行前6列数据
                mainRow = i
                mainRowData = wsSource.Range(wsSource.Cells(i, 1), wsSource.Cells(i, 6)).Value
            Case 2
                ' 批量读取关联行前4列数据
                assocRowData = wsSource.Range(wsSource.Cells(i, 1), wsSource.Cells(i, 4)).Value
                ' 批量写入到Export表对应行
                With wsExport.Cells(newRow, 1)
                    .Resize(1, 6).Value = mainRowData
                    .Offset(0, 6).Resize(1, 4).Value = assocRowData
                End With
                newRow = newRow + 1
        End Select
    Next i
    
    ' 自动调整列宽
    wsExport.UsedRange.EntireColumn.AutoFit
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

1. 界面交互禁用：开头关闭屏幕更新、事件和手动计算，避免每一步操作都刷新界面，这是VBA性能提升最直接的手段
2. 批量数据处理：用Variant数组一次性读取整行数据，再批量写入目标表，替代原代码中逐个单元格的Copy操作，速度提升数倍
3. 循环逻辑简化：从遍历所有单元格改为只遍历需要处理的行（6到lastRow），循环次数直接从几千次降到几百次
4. 工作表对象重用：提前定义wsSource和wsExport，避免重复调用Worksheets("Sheet1")或Sheets("Export")
5. 错误处理优化：删除Export表时改用On Error Resume Next处理表不存在的情况，比遍历所有工作表更高效

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