|
excelperfect 将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，供学习参考。 欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。 欢迎到知识星球：完美Excel社群，进行技术交流和提问，获取更多电子资料，并通过社群加入专门的微信讨论群，更方便交流。
|
|
|
来自： hercules028 > 《VBA》
