VBA/Excel问题：调用其他宏时.printarea刷新异常

更新：该问题仅在从其他宏调用时出现。

相关调用宏代码 #

Sub DAForm2062()
Application.ScreenUpdating = False
Clear
If DAFillFunc() Then
PDFGenerator
End If
Application.ScreenUpdating = True
End Sub

问题详情 #

此子程序根据列表中添加的项目数量打印对应页数。目前遇到的问题是：.printarea无法每次打印都更新，首次打印使用旧的.printarea，再次打印才会使用新的.printarea并输出正确页数。

已尝试的无效方法：

• 在调用PDFGenerator的其他子程序中重置.printarea
• 强制计算
• 添加等待时间

PDFGenerator宏代码 #

Sub PDFGenerator()
    Dim savePath As String
    Dim ws2062 As Worksheet
    Dim printArea As Range
    Dim currentPage As Long
    Dim totalPages As Long
    On Error GoTo ErrorHandler
    
    ' Set default page range as 10
    totalPages = 10
    ' Set the worksheet and print area range
    Set ws2062 = ThisWorkbook.Worksheets("2062")
    Set printArea = ws2062.Range("A1:U248")

    ' Determine the actual number of pages based on data
    If ws2062.Range("E27").Value = "" Then
        Set printArea = ws2062.Range("A1:U23")
        totalPages = 1
    ElseIf ws2062.Range("E52").Value = "" Then
        Set printArea = ws2062.Range("A1:U48")
        totalPages = 2
    ElseIf ws2062.Range("E77").Value = "" Then
        Set printArea = ws2062.Range("A1:U73")
        totalPages = 3
    ElseIf ws2062.Range("E102").Value = "" Then
        Set printArea = ws2062.Range("A1:U98")
        totalPages = 4
    ElseIf ws2062.Range("E127").Value = "" Then
        Set printArea = ws2062.Range("A1:U123")
        totalPages = 5
    ElseIf ws2062.Range("E152").Value = "" Then
        Set printArea = ws2062.Range("A1:U148")
        totalPages = 6
    ElseIf ws2062.Range("E177").Value = "" Then
        Set printArea = ws2062.Range("A1:U173")
        totalPages = 7
    ElseIf ws2062.Range("E202").Value = "" Then
        Set printArea = ws2062.Range("A1:U198")
        totalPages = 8
    ElseIf ws2062.Range("E227").Value = "" Then
        Set printArea = ws2062.Range("A1:U223")
        totalPages = 9
    End If

    ' Update the page numbers
    For currentPage = 1 To totalPages
        ws2062.Range("R" & (currentPage * 25 - 2) & ":U" & (currentPage * 25 - 2)).Value = "Page " & currentPage & " of " & totalPages
    Next currentPage
    
    With ActiveSheet.PageSetup
        .Orientation = xlLandscape
        .Zoom = False
        .printArea = printArea.Address
        .FitToPagesWide = False
        .FitToPagesTall = False
        .Zoom = 87
        .LeftMargin = Application.InchesToPoints(0.4)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.3)
        .BottomMargin = Application.InchesToPoints(0)

    End With
    'ActiveSheet.ResetAllPageBreaks 'Used during creation to reset page breaks and layout of the pdf, activate then de-activate
    ActiveWorkbook.Sheets(Array("2062")).Select
    
    'Location of the workbook and Updated 2062's folder. I place mine on the desktop.
    savePath = ThisWorkbook.Path & "\Updated 2062's\"

    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
'Saves to savePath
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=savePath & "DA Form 2062 " & ActiveSheet.Shapes("To").TextFrame.Characters.text & Format(Date, " - yyyymmdd"), _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
        
ErrorHandler:
    If Err.Description Like "*Document not saved*" Then
        MsgBox "The PDF is already open. Close it and try again.", vbExclamation, "File Already Open"
    End If
End Sub

解决方案 #

问题根源在于代码依赖ActiveSheet，调用宏时活动工作表可能不是目标工作表ws2062，导致PageSetup设置未生效；同时屏幕更新关闭可能延迟PrintArea的刷新。

修改步骤：

1. 替换所有ActiveSheet为明确的ws2062对象，避免依赖活动工作表
2. 设置PrintArea后强制重置分页符并刷新布局
3. 添加DoEvents让Excel处理完后台任务，确保更新生效

修改后的核心代码片段：

Sub PDFGenerator()
    Dim savePath As String
    Dim ws2062 As Worksheet
    Dim printArea As Range
    Dim currentPage As Long
    Dim totalPages As Long
    On Error GoTo ErrorHandler
    
    totalPages = 10
    Set ws2062 = ThisWorkbook.Worksheets("2062")
    ws2062.Activate ' 确保目标工作表激活
    Set printArea = ws2062.Range("A1:U248")

    ' ... 保留原有的页数判断代码 ...

    ' 更新页码
    For currentPage = 1 To totalPages
        ws2062.Range("R" & (currentPage * 25 - 2) & ":U" & (currentPage * 25 - 2)).Value = "Page " & currentPage & " of " & totalPages
    Next currentPage
    
    ' 直接操作目标工作表的PageSetup
    With ws2062.PageSetup
        .Orientation = xlLandscape
        .Zoom = False
        .printArea = printArea.Address
        .FitToPagesWide = False
        .FitToPagesTall = False
        .Zoom = 87
        .LeftMargin = Application.InchesToPoints(0.4)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.3)
        .BottomMargin = Application.InchesToPoints(0)
    End With
    
    ' 重置分页符并强制刷新
    ws2062.ResetAllPageBreaks
    Application.CalculateFullRebuild
    DoEvents ' 等待Excel完成后台更新
    
    ' 保存PDF时直接使用ws2062，不再依赖ActiveSheet
    savePath = ThisWorkbook.Path & "\Updated 2062's\"
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    ws2062.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=savePath & "DA Form 2062 " & ws2062.Shapes("To").TextFrame.Characters.Text & Format(Date, " - yyyymmdd"), _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
        
ErrorHandler:
    If Err.Description Like "*Document not saved*" Then
        MsgBox "The PDF is already open. Close it and try again.", vbExclamation, "File Already Open"
    End If
End Sub

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