向大师们请教：有若干个独立的word文档，分别将其复制到Excel以便提取数据，然后在Excel中复制提取到的数据；于是想通过再粘贴方式生成一个独立的word文档。下面的代码已经到复制的一步了，请教各位老师，有没有什么办法能实现？我尝试了通过获取剪切板数据粘贴后是可以生成一个word文档，但是图片和表格都没有了。紫色部分代码是有问题的，之前的都能运行。

Private Sub Command1_Click()
Dim xlApp As Excel.Application '定义EXCEL类
Dim xlBook As Excel.Workbook '定义工件簿类
Dim xlsheet As Excel.Worksheet '定义工作表类
Dim WordApp
Dim word
Dim i, n, a
Set WordApp = CreateObject("word.application")
WordApp.Visible = True '
Set word = WordApp.Documents.Open("d:\001\001.doc")
WordApp.Selection.WholeStory
WordApp.Selection.Copy
    WordApp.Quit
    Set myDoc = Nothing
    Set WordApp = Nothing

Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
xlApp.Visible = True '设置EXCEL可见
Set xlBook = xlApp.Workbooks.Open("D:\001\001.xls") '打开EXCEL工作簿
Set xlsheet = xlBook.Worksheets(1)   '打开EXCEL工作表
xlsheet.Activate '激活工作表
[A1].Select
Application.Wait Now() + TimeValue("00:00:04")
ActiveSheet.Paste

ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.Copy
    Sheets("111").Select
    Range("I3:I8").Select
    ActiveSheet.Paste
    Range("A1:I8").Select
    Selection.Copy
   
Dim WordObject As Object '声明一个对象变量，这里即将声明为Word对象
Set WordObject = CreateObject("Word.Application") '用set来创建Word对象，这里是运行Word程序，但未新建文档
WordObject.Visible = 0 '后台运行Word对象，只在任务管理器中存在WinWord.exe进程，但在任务栏上看不到word；如果为1或者True则可以看到word运行界面
WordObject.Documents.Add DocumentType:=wdNewBlankDocument '新建一word文档
WordObject.Application.Activate‘激活word
WordObject.ActiveWindow.Selection.Paste '将刚才从Excel中复制进剪贴板中的内容粘贴进word中来
WordObject.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果
WordObject.ActiveDocument.SaveAs "D:\001\009.doc" '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称
WordObject.Application.Quit '退出并关闭程序文档
Set WordObject = Nothing '释放对象


End Sub

1、这是execl中复制图表
 ActiveSheet.ChartObjects("图表 1").Activate
 ActiveChart.ChartArea.Copy

2、这是粘贴图表到word
 Selection.PasteAndFormat (wdChartLinked)

以上是通过宏录制的代码

另外你可以把原始要合并word和目标word发上来，看看是否有简单的合并方法。

再次感谢你的解答。问题基本解决了，我采用直接导出为PDF文件了。现在就是不知道怎么写循环了。

问题基本解决了，请教各位老师如何优化一下？尤其是如何释放Excel资源，要是运行多个表格后电脑就跑不动了，另外如果将word显示设置为false 程序运行就会报错word已停止工作。给大家添麻烦了。
代码如下：
Private Sub Command1_Click()

Dim xlApp As Excel.Application '定义EXCEL类
Dim xlBook As Excel.Workbook '定义工件簿类
Dim xlsheet As Excel.Worksheet '定义工作表类
Dim WordApp
Dim word
Dim i
Dim i1, i2 As Integer

i1 = Text1.Text
i2 = Text2.Text

For i = i1 To i2

Set WordApp = CreateObject("word.application")
WordApp.Visible = 1 '
Set word = WordApp.Documents.Open("d:\001\" & i & ".doc")
WordApp.Selection.WholeStory
WordApp.Selection.Copy
    WordApp.Quit
    Set myDoc = Nothing
    Set WordApp = Nothing

Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
xlApp.Visible = 0 '设置EXCEL可见
Set xlBook = xlApp.Workbooks.Open("D:\001\001.xls") '打开EXCEL工作簿
Set xlsheet = xlBook.Worksheets(1)   '打开EXCEL工作表
xlsheet.Activate '激活工作表
[A1].Select
Application.Wait Now() + TimeValue("00:00:04")
ActiveSheet.Paste


ActiveSheet.Shapes.Range(Array("Picture " & i & "")).Select
    Selection.Copy
    Sheets("111").Select
    Range("I3:I8").Select
    ActiveSheet.Paste
   ' Range("A1:I8").Select
   ' Selection.Copy
   
Range("A1:I21").Select
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:="D:\001\002\" & i & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

ActiveSheet.Shapes.Range(Array("Picture " & i & "")).Select
    Selection.Delete
    Sheets("1").Select
    Selection.Delete
    Range("A1:I9").Select
    Selection.ClearContents
    ActiveWorkbook.Save


 Clipboard.Clear
 
Next i

End Sub