将Excel区域导出到Word

Question

从Excel使用VBA我想将一个范围从Excel复制到Word，但我被卡住了！我正试图通过手动重新创建我所做的事情

1. 选择单元格范围并复制
2. 打开Word文档
3. 选择"；粘贴特殊"；以及"；格式化文本(RTF(">

我已经尝试了在互联网上找到的多个版本的代码，但无法运行代码。我确实有"；Microsoft Word 16.0对象库"；在Excel中作为引用进行了检查。

我得到的错误是"；运行时错误91-对象变量或块变量未设置"；。我在下面的代码中标记了它失败的地方。当我运行此程序时，它会启动Word，但不会打开新文档。

这是让我走得最远的代码。

Sub ExcelToWord()

Dim PageNumber As Integer
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim FileToOpen As String
Dim strPath As String

FileToOpen = "Excel Link test.docx"
strPath = "C:"

'the next line looks to a cell to decide what page number to scroll to
PageNumber = 1 'Later

On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open(strPath & FileToOpen)
Else
On Error GoTo notOpen
Set wrdDoc = wrdApp.Documents(FileToOpen)
GoTo OpenAlready
notOpen:
Set wrdDoc = wrdApp.Documents.Open(strPath & FileToOpen)
End If

OpenAlready:

On Error GoTo 0
Range("A6:D11").Copy ' med WS Name
With wrdApp
'------> Fails Here
.Selection.Goto What:=1, Which:=2, Name:=PageNumber
.Visible = True
.Selection.Paste
End With
Set wrdDoc = Nothing
Set wrdApp = Nothing

End Sub

一如既往，谢谢你的帮助！

Answer 1

请测试下一个代码。它将打开一个新的空白文档并使用它，而不是由代码打开的文档：

Sub ExcelToWord() 
Dim PageNumber As Integer, wrdApp As Word.Application, wrdDoc As Word.Document
Dim sh As Worksheet

Set sh = ActiveSheet 'use here the sheet you need
PageNumber = 1

On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
err.Clear: On Error GoTo 0
Set wrdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wrdDoc = wrdApp.Documents.Add 'add a blank document
wrdApp.Visible = True             'make Word application visible
'only for debugging, if not want to be visible
'and you will save it (programmatically) in the next steps...
sh.Range("A6:D11").copy ' med WS Name
With wrdApp
.Selection.Goto What:=1, which:=2, Name:=PageNumber
.Visible = True
.Selection.Paste
End With
Set wrdDoc = Nothing: Set wrdApp = Nothing
End Sub