Excel 第二次运行同一VBA代码时出现错误消息462

我有一个Excel表格，单元格A1中有标题，单元格A2-H5中有值。 下面的代码正在创建Word文档，将表格复制到该Word文档中，并更改表格的行高。第一次就可以了。 但当Word关闭并再次运行相同的代码时，它在第620行中断，错误代码为462。 似乎我的代码并不完美，Word正在使用一个hidde全局变量，当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

---

你的代码需要一些清理。设置表格行高时，存在未使用的变量、不必要的选择和不合格的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

---

L610工作得很顺利吗？如中所示，如果您注释掉屏幕更新加速，您可以观察它的运行情况？这可能很有用：我几乎可以肯定问题出在

InchesToPoint

-这需要完全声明，或者

Application.InchesToPoint

或者

WordApp.InchesToPoint

。请看类似的问题。嗨，很抱歉回复太晚，我的家人被新冠病毒感染，不得不单独离开。我已经试过你的代码了，非常感谢！！！那样的话，请看