VBA实用小程序：将Excel中的内容输入到Word

将Excel数据输入到Word文档并不难，但这会破坏书签，如果你在对Word文档进行了大量修改后发现想要重新从Excel中输入数据，那可能会令人沮丧。我想要一个可以根据需要经常重复的将Excel数据输入到Word，这意味着在复制完成后要重新创建书签。

在此情况下，我想要一些简单的东西，任何人都可以在没有技术知识的情况下进行设置。因此，下面的这段代码很简单，对其进行设置，只需为Excel中的文本、区域和图表命名，并按照代码中的说明在Word书签中创建匹配的名称。

注意，我不能保证它在所有情况下都能工作。

完整的代码：

'这里的代码使用书签将图表和表复制到Word文档中

'Word文档必须打开并处于活动状态,即当前可见的Word文档

'要复制一个表，给它一个以tbl开头的区域名称

'然后在Word文档中插入一个使用该名称的书签,

'如果表的名称是tblPerf3Yrs,则在该名称前加上tag_前缀

'然后添加书签tag_tblPerf3Yrs

'与图表类似,可以为图表命名以"cht"开头

'确保选择完整的图表,而不仅仅是其中的一部分

'在给它一个名字时,最安全的是点击图表前按Ctrl

'然后你在Word中包含一个具有此名称的书签,同样以 tag_ 为前缀

'运行下面的宏应该复制所有内容

'注意这种方法意味着不能多次插入相同的图表/表格

'因为Word出于显而易见的原因不允许重复的书签名称

Dim WdApp As Object 'Word.Application

Dim doc As Object 'Word.Document

Dim t

'主程序

Public Sub MergeToWord()

Application.Calculation= xlCalculationManual

Application.ScreenUpdating = False

'打开Word

Set WdApp= Nothing

Set doc =Nothing

On Error Resume Next

Set WdApp= GetObject(, "Word.Application")

If Err<> 0 Then

MsgBox "检查Word文档是打开的"

Exit Sub

End If

'获取活动文档

Set doc =WdApp.ActiveDocument

If Err<> 0 Then

MsgBox "连接到当前Word文档时错误: " &Err.Message

Exit Sub

End If

On Error GoTo 0

'处理表和图表

'在Word中查找所有相关标签并处理它们

ReDim B(WdApp.ActiveDocument.bookmarks.Count) As Object

Dim i As Long

'在数组中存储标签, 然后逐一处理它们

'不能遍历它们因为当发生粘贴时Word销毁了它们

'下面的代码重新创建它们,

'但这会抛出编号并使普通循环难以在数组中存储书签

For i = 1 To WdApp.ActiveDocument.bookmarks.Count

Set B(i) = WdApp.ActiveDocument.bookmarks(i)

Next i

'处理它们

For i = 1 To UBound(B)

If InStr(1, B(i).Name, "tag_", vbTextCompare) = 1 Then

PasteToWord B(i)

End If

Next i

'激活Word以便用户能核查结果

WdApp.Activate

Set WdApp= Nothing

Application.StatusBar= False

t = Timer- t

End Sub

'处理Word标签

Private Sub PasteToWord(B As Object, OptionalMethod As String = "Metafile") 'tag As String)

On Error Resume Next

Dim strTag As String

Dim tag As String

tag =B.Name

strTag =Mid$(B.Name, 5)

If Err<> 0 Then Exit Sub

On Error GoTo 0

'选择书签区域

B.Range.Select

'标记书签的开始

Dim rngMark As Object

Set rngMark = WdApp.Selection.Range

'b.Range.Text = vbNullString

'b.Range.Delete

'基于标签名, 选择是否粘贴表或图表

If InStr(tag, "tag_tbl") > 0 Then

rngMark.Collapse 1

PasteTableToWord B

ElseIf InStr(tag, "tag_cht") > 0 Then

'b.Range.Text = vbNullString

'rngMark.Collapse 1

B.Range.Delete

'b.Range.Select

CopyChartToWord B, rngMark, Method

rngMark.End = WdApp.Selection.End

WdApp.ActiveDocument.bookmarks.Add tag, rngMark

ElseIf InStr(tag, "tag_txt") > 0 Then

rngMark.Collapse 1

PasteTextToWord B

ElseIf InStr(tag, "tag_pic") > 0 Then

rngMark.Collapse 1

PastePicToWord B

Else

Exit Sub

End If

If InStr(tag, "tag_cht") = 0 Then

'标记粘贴内容的结尾

rngMark.End = WdApp.Selection.End

'再次添加书签

WdApp.ActiveDocument.bookmarks.Add tag, rngMark

End If

'清理

Cleanup:

Application.CutCopyMode = False

Application.StatusBar = False

End Sub

'粘贴文本

'标签必须作为Excel中的区域存在才能使其工作

Private Sub PasteTextToWord(B As Object)

Dim strTag As String

On Error Resume Next

strTag =Mid$(B.Name, 5)

If Err<> 0 Then Exit Sub

On Error GoTo 0

Dim txtTag As String

Dim u As Long

txtTag =strTag

On Error Resume Next

Range(txtTag).Copy

If Err =0 Then

If InStr(1, txtTag, "txt", vbTextCompare) > 0 Then

With WdApp.Selection

.Select

.ClearContents

.PasteAndFormat (22)

End With

Else

With WdApp.Selection

.Select

.ClearContents

WdApp.Selection.PasteAndFormat (22)

End With

End If

Else

WdApp.ActiveDocument.Selection = "*** 没有找到 ***"

End If

On Error GoTo 0

End Sub

Private Sub PastePicToWord(B As Object)

Dim strTag As String

On Error Resume Next

strTag =Mid$(B.Name, 5)

If Err<> 0 Then Exit Sub

On Error GoTo 0

Dim txtTag As String

Dim u As Long

txtTag =strTag

'查找图表

Dim w As Worksheet, pic As Picture

For Each w In ActiveWorkbook.Sheets

Set pic = w.Pictures(strTag)

If Not pic Is Nothing Then Exit For

Next w

If pic Is Nothing Then Exit Sub

On Error Resume Next

pic.Copy

If Err =0 Then

WdApp.Selection.Paste 'Special Link:=False, DataType:=8, Placement:=0 'shape, inline

End If

On Error GoTo 0

End Sub

'粘贴表

'标签必须作为Excel中的区域存在才能使其工作

Private Sub PasteTableToWord(B As Object)

Dim strTag As String

On Error Resume Next

strTag =Mid$(B.Name, 5)

If Err<> 0 Then Exit Sub

On Error GoTo 0

Dim tblTag As String

Dim u As Long

tblTag =strTag

On Error Resume Next

Range(tblTag).Copy

If Err =0 Then

If InStr(1, tblTag, "tbl", vbTextCompare) > 0 Then

With WdApp.Selection

.Tables(1).Select

.Tables(1).Delete

.PasteSpecial DataType:=1, Placement:=0 '9

'.PasteAndFormat (0) '默认粘贴

End With

Else

With WdApp.Selection

.Tables(1).Select

.Tables(1).Delete

WdApp.Selection.PasteAndFormat (22) '纯文本

End With

EndIf

Else

WdApp.ActiveDocument.Selection = "*** 没有找到 ***"

End If

On Error GoTo 0

End Sub

'复制图表

'图表名称必须与 Word 标签相同才能工作

'图表必须在当前工作表中

'Method可以是下面在Select Case子句中列出的任何值

Private Sub CopyChartToWord(B As Object, rngMark,Optional Method As String = "Metafile")

On Error Resume Next

Dim strTag As String

strTag =Mid$(B.Name, 5)

If Err<> 0 Then Exit Sub

On Error GoTo 0

'查找图表

Dim w As Worksheet, cht As ChartObject

For Each w In ActiveWorkbook.Sheets

Set cht = w.ChartObjects(strTag)

If Not cht Is Nothing Then Exit For

Next w

If cht Is Nothing Then Exit Sub

On Error Resume Next

cht.Copy

If Err =0 Then

Select Case Method

Case "Metafile"

rngMark.PasteSpecial DataType:=3, Placement:=0 '图元文件,内联

Case "Enhanced metafile"

WdApp.Selection.PasteSpecialDataType:=9, Placement:=0 '图元文件,内联

Case "Bitmap"

WdApp.Selection.PasteSpecial DataType:=4, Placement:=0 '图元文件,内联

Case "Drawing"

WdApp.Selection.PasteSpecial link:=False, DataType:=8, Placement:=0 '形状, 内联

Case "JPG"

Dim fName As String

fName = ThisWorkbook.Path & "\tmp.jpg"

cht.Chart.Export fName, "JPG"

WdApp.Selection.InlineShapes.AddPicture Filename:=fName,LinkToFile:=False, SaveWithDocument:=True

Kill fName

End Select

Else

WdApp.ActiveDocument.Selection.Text = "*** 没有找到 ***"

End If

On Error GoTo 0

End Sub

注：本程序整理自www.mrexcel.com，供学习参考。