通过VBA将Word表单导入Excel耗时过长，求优化方案

你的代码运行缓慢的核心原因是反复与Excel单元格进行交互——每次写入单个单元格都会触发Office对象模型的底层操作，150个控件就要执行几百次这类操作，再加上Excel默认的屏幕更新、自动计算等机制，自然会拖慢速度。下面是几个立竿见影的优化方案：

1. 关闭Excel的“拖后腿”功能 #

Excel默认的屏幕更新、自动计算、事件触发会在每次写入单元格时消耗大量资源，先暂时关闭这些功能，执行完导入后再恢复：

' 保存原始设置，避免影响后续操作
Dim origScreenUpd As Boolean, origCalc As XlCalculation, origEvents As Boolean
origScreenUpd = Application.ScreenUpdating
origCalc = Application.Calculation
origEvents = Application.EnableEvents

' 禁用耗时功能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

' --- 你的导入代码放在这个区域 ---

' 恢复原始设置
Application.ScreenUpdating = origScreenUpd
Application.Calculation = origCalc
Application.EnableEvents = origEvents

2. 用数组批量写入，避免逐个单元格填充 #

把所有数据先存入内存数组，最后一次性写入Excel，这能把几百次交互操作压缩成1次，大幅提升速度：

With myDoc
    ' 提前定义数组大小：按控件数量设行数，8列足够存储标签+内容+ID
    Dim dataArr() As Variant
    ReDim dataArr(1 To .ContentControls.Count, 1 To 8)
    
    Dim i As Integer
    i = 0
    For Each CCtl In .ContentControls
        i = i + 1
        Dim Tags As Variant
        Tags = Split(CCtl.Tag, ";")
        
        ' 填充标签列（最多取前5个标签，对应原代码逻辑）
        Dim x As Integer
        For x = 0 To UBound(Tags)
            If x < 5 Then
                dataArr(i, x + 1) = Tags(x)
            End If
        Next x
        
        ' 填充表单内容和BieterID
        dataArr(i, 6) = CCtl.Range.Text
        dataArr(i, 7) = BieterID
    Next
    
    ' 一次性将数组写入工作表
    myWkSht.Range("A1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)).Value = dataArr
    myWkSht.Columns.AutoFit
End With

3. 细节优化（锦上添花） #

• 把j=1移到循环外面，原代码每次循环都重复赋值，完全没必要；
• 如果CCtl.Range.Text访问速度慢，先把内容存入变量再使用，减少与Word对象的交互：

  Dim ctlText As String
  ctlText = CCtl.Range.Text
  dataArr(i, 6) = ctlText
  

将这些优化组合后，你的代码运行时间应该能从半小时压缩到几十秒以内。

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