word通过邮件合并功能批量复制excel文件表格并生成单独的文档

sugar_ice

最近在弄一个word批量文件生成的程序，就是通过把所有需要的资料文件统计在一个excel表里面（一行代表一个信息条），然后利用word邮件合并的功能，读取每一条记录，并根据记录中的表的名称，打开相应的表格，然后全选复制表的内容到word模版中指定的位置。现遇到了程序占用系统资源大的问题，剪切板中占用的资源多，希望有人来帮下优化下

lhdcxz

http://club.excelhome.net/thread-838620-1-1.html
供参考

sugar_ice

lhdcxz 发表于 2013-9-16 11:06
http://club.excelhome.net/thread-838620-1-1.html
供参考

感谢分享，很有参考价值，但是我这个比较复杂点，word打开多个excel文档复制黏贴的时候，还是很占据系统资源。求帮忙优化下

zhanglei1371

看来你应该写出了代码，何不把你的代码贴出来，这样稍作修改就可以了、

sugar_ice

zhanglei1371 发表于 2013-9-17 10:48
看来你应该写出了代码，何不把你的代码贴出来，这样稍作修改就可以了、

Sub myMailMerge()
    '主文档的类型为信函
    '合并全部数据记录
    '假设主文档已链接好数据源，可以进行正常的邮件合并
    Dim myMerge As MailMerge, i As Integer
    Dim table1app
    Dim table2app
    Dim table3app
    Dim myname As String
    Dim table1 As String
    Dim table2 As String
    Dim table3 As String
    'Application.ScreenUpdating = False
    Set myMerge = ActiveDocument.MailMerge
    With myMerge.DataSource
        If .Parent.State = wdMainAndDataSource Then
            .ActiveRecord = wdFirstRecord
            For i = 1 To .RecordCount
                .FirstRecord = i
                .LastRecord = i
                .Parent.Destination = wdSendToNewDocument
                '取得数据源第1个和第2个字段（合并域）的当前数据字符串，用以命名文件
                myname = .DataFields(1).Value
                table1 = .DataFields(7).Value
                table2 = .DataFields(8).Value
                table3 = .DataFields(9).Value
                .ActiveRecord = wdNextRecord
                .Parent.Execute  '每次合并一个数据记录
                With ActiveDocument
                    '.Content.Characters.Last.Previous.Delete  '删除分节符
                    .Fields(1).ShowCodes = False
                    .Fields.Update
                    Set table1app = CreateObject("excel.application")
                        With table1app
                           .Visible = False
                           .workbooks.Open "D:\数据文件\" & table1 & ".xlsx"
                           .ActiveSheet.UsedRange.Copy
                           ActiveDocument.Application.Selection.EndKey unit:=wdStory      '（希望定位在“表1：”下一行然后黏贴表格）
                           ActiveDocument.Application.Selection.TypeParagraph             '（希望定位在“表1：”下一行然后黏贴表格）
                           ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                           ActiveDocument.Application.ScreenUpdating = False
                            .ActiveWorkbook.Close
                            .Quit
                         End With
                         ActiveDocument.Application.Selection.TypeParagraph
                         Set table2app = CreateObject("excel.application")
                        With table2app
                           .Visible = False
                           .workbooks.Open "D:\数据文件\" & table2 & ".xlsx"
                           .ActiveSheet.UsedRange.Copy
                           ActiveDocument.Application.Selection.EndKey unit:=WholeStory        '（希望定位在“表2：”下一行然后黏贴表格）
                           ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                           ActiveDocument.Application.ScreenUpdating = False
                            .ActiveWorkbook.Close
                            .Quit
                         End With
                           ActiveDocument.Application.Selection.TypeParagraph
                           Set table3app = CreateObject("excel.application")
                          With table3app
                           .Visible = False
                           .workbooks.Open "D:\数据文件\" & table3 & ".xlsx"
                           .ActiveSheet.UsedRange.Copy
                           ActiveDocument.Application.Selection.EndKey unit:=WholeStory       '（希望定位在“表3：”下一行然后黏贴表格）
                           ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                           ActiveDocument.Application.ScreenUpdating = False
                            .ActiveWorkbook.Close
                            .Quit
                         End With
                        
                    .SaveAs "d:\" & myname & ".doc"  '假设生成的各文档保存于E盘根目录下
                    .Close  '关闭生成的文档（已保存）
                End With
             Next
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "OK啦"
    End sub
这是我最开始想的   具体的在模版VBE里面有代码的,可以去看一下，刚看了楼上哥们给的参考，想到是不是可以把复制复制表格的代码做成一个模块，通过循环调用程序就好

zhanglei1371

关于这一句Set table1app = CreateObject("excel.application")
试试这样：先判定是否有已经打开的excel程序，然后没有的话再创建；
    On Error Resume Next
     Set  table1app = GetObject(, "excel.application")
    If Err.Number > 0 Then
        Set  table1app = CreateObject("Excel.Application")
         table1app.Visible = True
    End If
关于剪贴板的话，试试使用api实时清空：
Private Declare Function CloseClipboard Lib "user32" () As Long
EmptyClipboard代码修改如下：
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Sub myMailMerge()
'主文档的类型为信函
'合并全部数据记录
'假设主文档已链接好数据源，可以进行正常的邮件合并
    Dim myMerge As MailMerge, i As Integer
    Dim table1app
    Dim table2app
    Dim table3app
    Dim myname As String
    Dim table1 As String
    Dim table2 As String
    Dim table3 As String
    'Application.ScreenUpdating = False
    Set myMerge = ActiveDocument.MailMerge
    With myMerge.DataSource
        If .Parent.State = wdMainAndDataSource Then
            .ActiveRecord = wdFirstRecord
            For i = 1 To .RecordCount
                .FirstRecord = i
                .LastRecord = i
                .Parent.Destination = wdSendToNewDocument
                '取得数据源第1个和第2个字段（合并域）的当前数据字符串，用以命名文件
                myname = .DataFields(1).Value
                table1 = .DataFields(7).Value
                table2 = .DataFields(8).Value
                table3 = .DataFields(9).Value
                .ActiveRecord = wdNextRecord
                .Parent.Execute  '每次合并一个数据记录
                With ActiveDocument
                    '.Content.Characters.Last.Previous.Delete  '删除分节符
                    .Fields(1).ShowCodes = False
                    .Fields.Update
                    On Error Resume Next
                    Set table1app = GetObject(, "excel.application")
                    If Err.Number > 0 Then
                        Set table1app = CreateObject("Excel.Application")
                        table1app.Visible = True
                    End If
                    With table1app
                        .Visible = True
                        .workbooks.Open "C:\数据文件\" & table1 & ".xlsx"
                        .ActiveSheet.UsedRange.Copy
                        ActiveDocument.Application.Selection.EndKey unit:=wdStory      '（希望定位在“表1：”下一行然后黏贴表格）
                        ActiveDocument.Application.Selection.TypeParagraph             '（希望定位在“表1：”下一行然后黏贴表格）
                        ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                        ActiveDocument.Application.ScreenUpdating = False
                        OpenClipboard 0&
                        EmptyClipboard
                        CloseClipboard
                        .ActiveWorkbook.Close False
                        '                        .Quit
                    End With
                    ActiveDocument.Application.Selection.TypeParagraph
                    Set table2app = GetObject(, "excel.application")
                    With table2app
                        .Visible = True
                        .workbooks.Open "C:\数据文件\" & table2 & ".xlsx"
                        .ActiveSheet.UsedRange.Copy
                        ActiveDocument.Application.Selection.EndKey unit:=WholeStory        '（希望定位在“表2：”下一行然后黏贴表格）
                        ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                        ActiveDocument.Application.ScreenUpdating = False
                        OpenClipboard 0&
                        EmptyClipboard
                        CloseClipboard
                        .ActiveWorkbook.Close False
                    End With
                    ActiveDocument.Application.Selection.TypeParagraph
                    Set table3app = GetObject(, "excel.application")
                    With table3app
                        .Visible = True
                        .workbooks.Open "C:\数据文件\" & table3 & ".xlsx"
                        .ActiveSheet.UsedRange.Copy
                        ActiveDocument.Application.Selection.EndKey unit:=WholeStory       '（希望定位在“表3：”下一行然后黏贴表格）
                        ActiveDocument.Application.Selection.PasteExcelTable False, False, False
                        ActiveDocument.Application.ScreenUpdating = False
                        OpenClipboard 0&
                        EmptyClipboard
                        CloseClipboard
                        .ActiveWorkbook.Close False
                    End With
                    .SaveAs "C:\" & myname & ".doc"  '假设生成的各文档保存于E盘根目录下
                    .Close  '关闭生成的文档（已保存）
                End With
            Next
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "OK啦"
End Sub


关于循环问题，应该不是难事。可以进一步简化，我就不去思考了{:soso_e113:}

tsrlzx

需要学的东西太多了。

doris_9898

最后搞不懂文件到底保存哪了