第二次运行相同的 VBAcode 时出现错误消息 462

Question

我在 Excel 中有一个表格，单元格 A1 中的标题和单元格 A2-H5 中的值。 下面的代码是创建一个 Word 文档，将表格复制到该 Word 文档中并更改表格的行高。它第一次工作正常。 但是当 Word 关闭并再次运行相同的代码时，它会在第 620 行中断，错误代码为 462。 看来我的代码并不完美，Word 使用了一个隐藏的全局变量，该变量在 Word 关闭时关闭。

谁能帮我避免这个错误信息？

Sub TestError()
10 On Error GoTo Err
20
30           Dim tbl As Excel.Range
40           Dim WordApp As Word.Application
50           Dim myDoc As Word.Document
51           Dim myDoc1 As Word.Document
60           Dim WordTable As Word.Table
70           Calculate
80           'Optimize Code
90               Application.ScreenUpdating = False
100              Application.EnableEvents = False
110
120          'Create an Instance of MS Word
130              On Error Resume Next
140
150          'Is MS Word already opened?
160              Set WordApp = GetObject(class:="Word.Application")
170
180          'Clear the error between errors
190              Err.Clear
200
210          'If MS Word is not already open then open MS Word
220              If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
230
240          'Handle if the Word Application is not found
250              If Err.Number = 429 Then
260                  MsgBox "Microsoft Word could not be found, aborting."
270                  GoTo EndRoutine
280              End If
290
300           On Error GoTo 0
310
320          'Make MS Word Visible and Active
330              WordApp.Visible = True
340              WordApp.Activate
350
360          'Create a New Document
380              Set myDoc = WordApp.Documents.Add
400
410          'Copy Excel Table Range
420              Worksheets("Sheet1").Visible = True
430              Worksheets("Sheet1").Select
431              Range("A1").Select
432              Selection.Copy
433              myDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
434              Worksheets("Sheet1").Select
440              Range("A2:H5").Select
450              Selection.Copy
460
470          'Paste Table into MS Word
480              myDoc.Paragraphs(2).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
490
500          'Set Margins
510              With WordApp.ActiveDocument.PageSetup
520              .Orientation = wdOrientPortrait
530              .TopMargin = WordApp.InchesToPoints(0.6)
540              .BottomMargin = WordApp.InchesToPoints(0.6)
550              .LeftMargin = WordApp.InchesToPoints(0.6)
560              .RightMargin = WordApp.InchesToPoints(0.6)
570              End With
580
590          'Autofit Table so it fits inside Word Document
600              Set WordTable = myDoc.Tables(1)
610              myDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
620              myDoc.Tables(1).Rows.SetHeight RowHeight:=InchesToPoints(0.22), HeightRule:=wdRowHeightExactly

EndRoutine:
640
650          'Optimize Code
660              Application.ScreenUpdating = True
670              Application.EnableEvents = True
680
690          'Clear The Clipboard
700              Application.CutCopyMode = False
710
720          Exit Sub
780
790 Err:
800          MsgBox Err.Number & " - " & Err.Description
860          Exit Sub
End Sub

Answer 1

您的代码可以做一些清理工作。设置表格行高时，您有未使用的变量、不必要的选择和不合格的 InchesToPoints 参考。试试：

Sub Test()
Application.ScreenUpdating = False
Dim WordApp As Word.Application, myDoc As Word.Document
Application.Calculate
Application.EnableEvents = False
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already running?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already running then start MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
  MsgBox "Microsoft Word could not be found, aborting."
  GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible
With WordApp
  .Visible = True
  'Create a New Document
  Set myDoc = .Documents.Add
  With myDoc
    'Set Margins
    With .PageSetup
      .Orientation = wdOrientPortrait
      .TopMargin = WordApp.InchesToPoints(0.6)
      .BottomMargin = WordApp.InchesToPoints(0.6)
      .LeftMargin = WordApp.InchesToPoints(0.6)
      .RightMargin = WordApp.InchesToPoints(0.6)
    End With
    'Copy Excel Table Range
    Worksheets("Sheet1").Range("A1").Copy
    .Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Worksheets("Sheet1").Range("A2:H5").Copy
    .Characters.Last.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    'Autofit Table so it fits inside Word Document
    With .Tables(1)
      .AutoFitBehavior (wdAutoFitWindow)
      .Rows.SetHeight RowHeight:=WordApp.InchesToPoints(0.22), HeightRule:=wdRowHeightExactly
    End With
  End With
  .Activate
End With
EndRoutine:
'Clear The Clipboard
Application.CutCopyMode = False
'Restore
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub