VBA Excel 到 Word - 在第二次循環運行時另存為 pdf 失敗

Question

我有下面的代碼，當我添加到保存到 pdf 的部分時，它按預期運行了單詞創建，它運行並保存了第一次。 第二個循環構建 word 文件並保存文件，但無法第二次完成 pdf 創建。 在循環中完成第二個 word 文件后，我收到以下錯誤。

運行時錯誤“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