VBA Excel 到 Word - 另存为 pdf 在第二次循环运行时失败

Question

我有下面的代码，当我在保存到 pdf 的部分中添加它时，它按预期运行以创建单词，它第一次运行并保存。第二个循环它构建 word 文件并保存文件，但未能第二次完成 pdf 创建。第二个单词文件在循环中完成后出现以下错误。

运行时错误“462” 远程服务器机器不存在或不可用

对 VBA 很陌生，所以对我的代码要温柔！

提前致谢，

大卫

Sub CreateBasicWordReport()
    
    Dim WdApp As Word.Application
    Dim SaveName As String
    Dim FileExt As String
    Dim LstObj1 As ListObject
    Dim MaxValue As Integer
    Dim FilterValue As Integer
    Dim Organisation As String
    Dim Rng As Range
    Dim WS As Worksheet
   
    Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
   
    MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
    
    FilterValue = MaxValue
    
    Do Until FilterValue = 0
    
    Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
    Sheets("Sheet1").Select
    
    Set WdApp = CreateObject("Word.Application")
    
    With WdApp
        .Visible = True
        .Activate
        
        .Documents.Add "C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx"
      
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
    Range("F11").Select
              
    Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
    
    .Selection.GoTo what:=-1, Name:="TableLocation"
    .Selection.Paste
    
    For Each Row In Range("Table1[#All]").Rows
    If Row.EntireRow.Hidden = False Then
        If Rng Is Nothing Then Set Rng = Row
        Set Rng = Union(Row, Rng)
    End If
    Next Row
    Set WS = Sheets("Static")
    Rng.Copy Destination:=WS.Range("A1")

    Sheets("Static").Select
    Sheets("Static").Activate
    Organisation = Range("D2").Value
    
    Sheets("Static").Select
    Range("D2").Copy
    .Selection.GoTo what:=-1, Name:="Organisation"
    .Selection.PasteAndFormat wdFormatPlainText
    Application.CutCopyMode = False
    
    Sheets("Static").Select
    Range("F2").Copy
    
    .Selection.GoTo what:=-1, Name:="MalePatients"

    .Selection.PasteAndFormat wdFormatPlainText
    Application.CutCopyMode = False
    
    Chart2.ChartArea.Copy
    
    .Selection.GoTo what:=-1, Name:="ChartLocation"
    .Selection.Paste
    
    If .Version <= 11 Then
        FileExt = ".doc"
    Else
        FileExt = ".docx"
    End If
    
    SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
        Organisation & " " & _
        Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
        
    If .Version <= 12 Then
        .ActiveDocument.SaveAs SaveName
    Else
        .ActiveDocument.SaveAs2 SaveName
    End If
    
    SaveNamePDF = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
    Organisation & " " & _
    Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"

    ActiveDocument.ExportAsFixedFormat _
    OutputFileName:=SaveNamePDF, _
    ExportFormat:=wdExportFormatPDF _

    
    .ActiveDocument.Close
    .Quit
    
    End With
    
    Set WdApp = Nothing
    
    FilterValue = FilterValue - 1
    
    Application.DisplayAlerts = False
    Sheets("Static").Delete
    Application.DisplayAlerts = True
    
    Loop
    
End Sub

Answer 1

正如@BigBen 指出的那样，您的循环中有一些命令应该在它之外。我已经重写了您的代码，以向您展示如何进行一些有助于优化代码的额外改进。

如果您避免选择事物，VBA 代码会运行得更快。这同样适用于 Excel 和 Word。这两个应用程序都有Range 对象，可以用来代替Selection。

您的代码中还有一个未声明的变量Row，因此您应该将其添加到变量声明中（最好使用不同的名称，尽管Row 是 Excel 中的一个对象，并且当变量具有同名）。您可以通过在代码模块顶部添加 Option Explicit 来避免这些问题。当您有未声明的变量时，这将阻止您的代码编译。要将其自动添加到新模块中，请打开 VBE 并转到工具 |选项。在“选项”对话框中，确保选中“要求变量声明”。

虽然对于刚接触 VBA 的人来说，这并不是一个糟糕的开始。

Sub CreateBasicWordReport()
   Dim WdApp As Word.Application
   Dim wdDoc As Word.document
   Dim SaveName As String
   Dim FileExt As String
   Dim LstObj1 As ListObject
   Dim MaxValue As Integer
   Dim FilterValue As Integer
   Dim Organisation As String
   Dim Rng As Range
   Dim WS As Worksheet
   
   Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
   
   MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
    
   FilterValue = MaxValue
    
   Set WdApp = CreateObject("Word.Application")
   Do Until FilterValue = 0
    
      Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
      Sheets("Sheet1").Select
    
      'moved outside of loop
      ' Set WdApp = CreateObject("Word.Application")
   
      With WdApp
         .Visible = True
         .Activate
         'create new document and assign to object variable
         Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx")
      'now mostly finished with WdApp as from here wdDoc is used
      End With
      ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
      Range("F11").Select
              
      Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
    
      '         .Selection.GoTo what:=-1, Name:="TableLocation"
      '         .Selection.Paste
      wdDoc.Bookmarks("TableLocation").Range.Paste
    
      For Each Row In Range("Table1[#All]").Rows
         If Row.EntireRow.Hidden = False Then
            If Rng Is Nothing Then Set Rng = Row
            Set Rng = Union(Row, Rng)
         End If
      Next Row
      Set WS = Sheets("Static")
      Rng.Copy Destination:=WS.Range("A1")

      '      Sheets("Static").Select
      '      Sheets("Static").Activate
      Organisation = WS.Range("D2").Value
    
      '      Sheets("Static").Select
      '      Range("D2").Copy
      WS.Range("D2").Copy
      
      '         .Selection.GoTo what:=-1, Name:="Organisation"
      '         .Selection.PasteAndFormat wdFormatPlainText
      wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
      Application.CutCopyMode = False
    
      '      Sheets("Static").Select
      '      Range("F2").Copy
      WS.Range("F2").Copy
      
    
      '         .Selection.GoTo what:=-1, Name:="MalePatients"
      '         .Selection.PasteAndFormat wdFormatPlainText
      wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
         
      Application.CutCopyMode = False
    
      Chart2.ChartArea.Copy
    
      '         .Selection.GoTo what:=-1, Name:="ChartLocation"
      '         .Selection.Paste
      wdDoc.Bookmarks("ChartLocation").Range.Paste
    
      If .Version <= 11 Then
         FileExt = ".doc"
      Else
         FileExt = ".docx"
      End If
    
      SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
         Organisation & " " & _
         Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
        
      If .Version <= 12 Then
         ' .ActiveDocument.SaveAs SaveName
         wdDoc.SaveAs SaveName
      Else
         ' .ActiveDocument.SaveAs2 SaveName
         wdDoc.SaveAs2 SaveName
      End If
    
      SaveNamePDF = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
         Organisation & " " & _
         Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"

      wdDoc.ExportAsFixedFormat _
         OutputFileName:=SaveNamePDF, _
         ExportFormat:=wdExportFormatPDF _

    
         wdDoc.Close
         'moved outside of loop
    
         'are you sure that these need to be inside the loop?
         FilterValue = FilterValue - 1
         Sheets("Static").Delete
    
   Loop

   WdApp.Quit
    
   Set WdApp = Nothing
   Application.DisplayAlerts = False
   Application.DisplayAlerts = True
    
End Sub