Question

我知道这与其他问题非常接近，但我未能通过其他发布的解决方案来确定我的问题，这就是我现在发布它的原因。我已在代码中指出在第二次迭代期间弹出错误。以下是similar question的示例。

Sub ExcelToWOrdCopy()

Dim objWord As Word.Application

LR = Cells(Rows.Count, 1).End(xlUp).Row
For x = 3 To LR

Call PrintScreen 'Print screen set in a module and works fine

Set objWord = CreateObject("Word.Application")
objWord.Documents.Open ("C:\Users\a222012\Desktop\EDD Results File.docx")
objWord.Visible = True
objWord.ActiveDocument.Bookmarks("ScreenShot").Range.Paste 'Bookmarks have been placed in above word document.

ActiveSheet.Range("C2:L2").Copy

objWord.ActiveDocument.Bookmarks("LinkName").Range.Paste
objWord.ActiveDocument.Tables(1).AutoFitBehavior (wdAutoFitWindow)

'Error on next line during 2nd iteration

objWord.ActiveDocument.Tables(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
objWord.ActiveDocument.Tables(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
objWord.ActiveDocument.Tables(1).Borders(wdBorderBottom).Color = Options.DefaultBorderColor

objWord.ActiveDocument.Tables(1).Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
objWord.ActiveDocument.Tables(1).Borders(wdBorderRight).LineWidth = Options.DefaultBorderLineWidth
objWord.ActiveDocument.Tables(1).Borders(wdBorderRight).Color = Options.DefaultBorderColor

ActiveSheet.Hyperlinks.Add Range(Cells(x, 3), Cells(x, 12)), Text
Range(Cells(x, 3), Cells(x, 12)).Copy

objWord.Visible = True
objWord.ActiveDocument.Bookmarks("Links").Range.Paste
objWord.ActiveDocument.Tables(2).AutoFitBehavior (wdAutoFitWindow)
objWord.ActiveDocument.SaveAs2 ("C:\Users\a222012\Desktop\EDD\" & (Cells(3, 1) & " - " & Cells(x, 1)))
objWord.Quit

Next x

Set objWord = Nothing

End Sub

Answer 1

正如在另一个答案和评论中所说，在循环中创建/使用一个Word实例会更好（也更稳定）。

我还添加了一些With来提高代码的可读性和性能：

Sub ExcelToWOrdCopy()
Dim objWord As Word.Application
Dim oDoc As Word.Document
Dim wS As Excel.Worksheet
'''Change sheet's name below
Set wS = ThisWorkbook.Sheets("Sheet1")
'''This will use existing instance of Word if there is one, or create a new one
On Error Resume Next
Set objWord = CreateObject("Word.Application")
On Error GoTo 0
If objWord Is Nothing Then Set objWord = CreateObject("Word.Application")
objWord.Visible = True

    LR = wS.Cells(wS.Rows.Count, 1).End(xlUp).Row
    For x = 3 To LR
        Call PrintScreen 'Print screen set in a module and works fine

        Set oDoc = objWord.Documents.Open("C:\Users\a222012\Desktop\EDD Results File.docx")

        With oDoc
            .Bookmarks("ScreenShot").Range.Paste 'Bookmarks have been placed in above word document.

            wS.Range("C2:L2").Copy
            objWord.Visible = True
            .Bookmarks("LinkName").Range.Paste

            With .Tables(1)
                .Tables(1).AutoFitBehavior (wdAutoFitWindow)
                With .Borders(wdBorderBottom)
                    .LineStyle = Options.DefaultBorderLineStyle
                    .LineWidth = Options.DefaultBorderLineWidth
                    .Color = Options.DefaultBorderColor
                End With '.Borders(wdBorderBottom)
                With .Borders(wdBorderRight)
                    .LineStyle = Options.DefaultBorderLineStyle
                    .LineWidth = Options.DefaultBorderLineWidth
                    .Color = Options.DefaultBorderColor
                End With '.Borders(wdBorderRight)
            End With '.Tables(1)

            wS.Hyperlinks.Add Range(wS.Cells(x, 3), wS.Cells(x, 12)), Text
            wS.Range(wS.Cells(x, 3), wS.Cells(x, 12)).Copy

            objWord.Visible = True
            .Bookmarks("Links").Range.Paste
            .Tables(2).AutoFitBehavior (wdAutoFitWindow)
            DoEvents
            .SaveAs2 ("C:\Users\a222012\Desktop\EDD\" & (Cells(3, 1) & " - " & Cells(x, 1)))
        End With 'oDoc
    Next x
objWord.Quit
Set objWord = Nothing
End Sub

'运行时错误462：第二次迭代期间，远程服务器计算机不存在或不可用“

1 个答案: