Excel VBA循环导出.atf工作表图表至Word书签异常排查

核心问题 #

原代码重复操作第一个.atf工作表的原因很明确：

1. 首次遍历工作表时，找到第一个符合条件的表就执行Exit For，导致WS变量一直绑定该表，后续循环未更新。
2. 逆序循环For i = Sheets.Count To 1 Step -1中，没有将WS指向当前索引的工作表，始终复用最初的WS对象。
3. 错误使用Resume Next语句，这是异常处理专用语法，此处直接跳过不符合条件的工作表即可。

修正后的代码 #

Private Sub CommandButton3_Click()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .DisplayAlerts = False
    .DisplayStatusBar = False
End With

Dim WS As Worksheet
Dim appWD As Object, wddoc As Object
Dim hasAtfSheets As Boolean
Dim targetRange As Object ' 缓存书签位置，避免反复选择操作

' 获取已打开的Word应用与文档
Set appWD = GetObject(, "Word.Application")
Set wddoc = appWD.Documents(1)
wddoc.Application.ScreenUpdating = False

' 检查是否存在目标工作表
hasAtfSheets = False
For Each WS In Worksheets
    If WS.Name Like "*.atf" Then
        hasAtfSheets = True
        Exit For
    End If
Next

If hasAtfSheets Then
    ' 绑定书签位置的Range对象，后续操作基于此对象
    Set targetRange = wddoc.Bookmarks("qfigs1").Range
    
    ' 逆序遍历所有工作表
    For i = Sheets.Count To 1 Step -1
        Set WS = Sheets(i) ' 关键：每次循环更新WS为当前工作表
        If WS.Name Like "*.atf" Then
            ' 插入分页符与标题
            With targetRange
                .Collapse Direction:=wdCollapseStart
                .InsertBreak Type:=wdPageBreak
                .Collapse Direction:=wdCollapseStart
                .Font.Bold = True
                .Text = "File " & WS.Range("A2").Value & " Recording Quality Figures"
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
            
            ' 导出Chart 3
            WS.ChartObjects("Chart 3").Copy
            With targetRange
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraph
                .Collapse Direction:=wdCollapseEnd
                .PasteSpecial DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, Link:=False, DisplayAsIcon:=False
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
            Application.CutCopyMode = False
            
            ' 导出Chart 2
            WS.ChartObjects("Chart 2").Copy
            With targetRange
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraph
                .Collapse Direction:=wdCollapseEnd
                .PasteSpecial DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, Link:=False, DisplayAsIcon:=False
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
            Application.CutCopyMode = False
            
            ' 导出Chart 1
            WS.ChartObjects("Chart 1").Copy
            With targetRange
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraph
                .Collapse Direction:=wdCollapseEnd
                .PasteSpecial DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, Link:=False, DisplayAsIcon:=False
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
            Application.CutCopyMode = False
        End If
    Next
Else
    MsgBox "没有可导出的图表"
    Exit Sub
End If

' 恢复Word与Excel的默认设置
wddoc.Application.ScreenUpdating = True
Set targetRange = Nothing
Set wddoc = Nothing
Set appWD = Nothing

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .DisplayAlerts = True
    .DisplayStatusBar = True
End With

MsgBox "所有图表已导出"

End Sub

关键优化点 #

• 动态更新WS对象：在逆序循环中添加Set WS = Sheets(i)，确保每次循环都操作当前遍历到的工作表。
• 复用书签Range：提前获取书签位置的Range对象，避免反复激活文档、选择区域的冗余操作，提升运行效率。
• 修正内容插入逻辑：通过Collapse和InsertParagraphAfter控制插入位置，确保所有内容都追加在书签区域的末尾，避免覆盖原有内容。
• 移除错误语法：删除无效的Resume Next语句，直接跳过不符合条件的工作表。

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