使用VBA将表格从Excel复制到Word书签

Question

请帮忙！我是新手！我想将表格从工作表"Table1"从excel转移到现有Word中的Bookmark1(模板格式为var.4.docx)。

这个宏的问题是，表被转移到word，但它会擦除word中的所有信息。并且该表不会出现在指定的Bookmark1位置。谢谢

我试图修改宏行，但没有成功。

' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Range
with:
Dim oRange
Set oRange = oDoc.Bookmark("Bookmark1")
Sub CommandButton1_Click()
On Error Resume Next
' FIRST GET THE ROWS COLUMNS OF A USED RANGE.
Dim iTotalRows As Integer   ' GET TOTAL USED RANGE ROWS.
iTotalRows = Worksheets("Table1").UsedRange.Rows.Count

Dim iTotalCols As Integer   ' GET TOTAL COLUMNS.
iTotalCols = Worksheets("Table1").UsedRange.Columns.Count

' WORD OBJECT.
Dim oWord As Object
Set oWord = CreateObject(Class:="Word.Application")
oWord.Visible = True
oWord.Activate
' ADD A DOCUMENT TO THE WORD OBJECT.
Dim oDoc
Set oDoc = oWord.Documents.Open("C:Usersstefan.georgescuDesktopTemplate fisa de esantionare var.4.docx")

' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Range
' CREATE AND  DEFINE TABLE STRUCTURE USING
' THE ROWS AND COLUMNS EXTRACTED FROM EXCEL USED RANGE.
oDoc.Tables.Add oRange, iTotalRows, iTotalCols

' CREATE A TABLE OBJECT.
Dim oTable
Set oTable = oDoc.Tables(1)
oTable.Borders.Enable = True      ' YES, WE WANT BORDERS.

Dim iRows, iCols As Integer

' LOOP THROUGH EACH ROW AND COLUMN TO EXTRACT DATA IN EXCEL.
For iRows = 1 To iTotalRows
For iCols = 1 To iTotalCols
Dim txt As Variant
txt = Worksheets("Table1").Cells(iRows, iCols)
oTable.cell(iRows, iCols).Range.Text = txt        ' COPY (OR WRITE) DATA TO THE TABLE.

' BOLD HEADERS.
If Val(iRows) = 1 Then
objTable.cell(iRows, iCols).Range.Font.Bold = True
End If
Next iCols
Next iRows
Set oWord = Nothing
End Sub

Answer 1

将文档添加到word对象之后。

您有：

' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Range

您需要：

' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Bookmarks("Bookmark1").Range

Answer 2

问题中显示的代码存在许多问题——由于On Error Resume Next，这些问题可能并不明显。这一点应该加以评论，尤其是在测试阶段。这个命令只是忽略错误，所以它不会告诉你什么时候不工作，更重要的是，不会有关于为什么结果不是预期的信息。我已经在下面的示例代码中评论了这一行。

我试图尽可能保持不变，但我确实以更合乎逻辑的顺序移动了一些声明和实例化。

虽然它不在代码的开头，但由于问题是关于将目标范围设置为书签位置，因此按如下方式进行。请注意，书签名称应该用引号括起来。根据书签的类型(无论是标记点还是包含内容)，书签都可能被删除。(包含内容的boookmark将被删除，内容也将被删除；"点书签"将保留，但不会包含表。)如果应该保留书签或应该包含表，则可以使用扩展代码来更改这一点。

Set oRange = oDoc.Bookmarks("Bookmark1").Range

请注意，通常最好在创建对象时实例化("Set")对象，而不是事后实例化。因此，例如

Set oDoc = oWord.Documents.Open
Set oTable = oDoc.Tables.Add

由于只有第一行会被加粗，所以没有必要在循环中检查它是否是第一行，然后再加粗——每个"如果"都会花费时间/资源。因此，我将该命令移出了循环，删除了If，并添加了正确的变量名(oTable，而不是尚未在任何地方声明的objTable)。

在完成使用另一个应用程序中的对象(Excel中的Word对象，如图所示)的过程时，重要的是释放所有对象，而不仅仅是应用程序。这应该按照它们创建的相反顺序进行。我在末尾添加了那些额外的Set到Nothing行。

请注意，由于没有Excel数据，我无法测试此过程，因此可能会出现一些小的语法错误。

Sub TableFromXlToWd()
'    On Error Resume Next
' FIRST GET THE ROWS COLUMNS OF A USED RANGE.
Dim iTotalRows As Integer   ' GET TOTAL USED RANGE ROWS.
iTotalRows = Worksheets("Table1").UsedRange.Rows.Count
Dim iTotalCols As Integer   ' GET TOTAL COLUMNS.
iTotalCols = Worksheets("Table1").UsedRange.Columns.Count
' WORD OBJECT.
Dim oWord As Object
Set oWord = CreateObject(Class:="Word.Application")
oWord.Visible = True
oWord.Activate
' ADD A DOCUMENT TO THE WORD OBJECT.
Dim oDoc As Object  'Word.Document
Set oDoc = oWord.Documents.Open("C:Usersstefan.georgescuDesktopTemplate fisa de esantionare var.4.docx")       
' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange As Object 'Word.Range
Set oRange = oDoc.Bookmarks("Bookmark1").Range
' CREATE AND  DEFINE TABLE STRUCTURE USING
' THE ROWS AND COLUMNS EXTRACTED FROM EXCEL USED RANGE.
Dim oTable As Object 'Word.Table
Set oTable = oDoc.Tables.Add(oRange, iTotalRows, iTotalCols)
oTable.Borders.Enable = True      ' YES, WE WANT BORDERS.
Dim iRows, iCols As Integer
oTable.Cell(iRows, iCols).Range.Font.Bold = True        
' LOOP THROUGH EACH ROW AND COLUMN TO EXTRACT DATA IN EXCEL.
For iRows = 1 To iTotalRows
For iCols = 1 To iTotalCols
Dim txt As Variant
txt = Worksheets("Table1").Cells(iRows, iCols)
oTable.Cell(iRows, iCols).Range.text = txt        ' COPY (OR WRITE) DATA TO THE TABLE.
Next iCols
Next iRows
Set oTable = Nothing
Set oDoc = Nothing
Set oWord = Nothing
End Sub