将Excel数据对应写入已做好的Word模板的指定位置(统发)

jiminyanyan

请教个将Excel数据对应写入已做好的Word模板的指定位置的问题
需要达到的效果已经写在附件中，模板可能是２张或者多张。已经有部分代码，但是达不到我的效果。

chxw68

可以换个思路：不用模板，可以按照模板的格式重新写入所有内容，这样就简单多了。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr
   
4.   Dim wordapp As Object
   
5.   Dim mydoc As Word.Document
   
6.   Set wordapp = CreateObject("word.application")
   
7.   With Worksheets("数据")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:d" & r)
   
10.   End With
    
11.   With wordapp
    
12.     .Documents.Add
    
13.     With .Selection
    
14.       For i = 1 To UBound(arr)
    
15.         With .Font
    
16.           .Size = 22
    
17.           .Name = "宋体"
    
18.           .Bold = True
    
19.         End With
    
20.         .ParagraphFormat.Alignment = wdAlignParagraphCenter
    
21.         .TypeText Text:="工资通知"
    
22.         .TypeParagraph
    
23.         .TypeParagraph
    
24.         With .Font
    
25.           .Size = 22
    
26.           .Name = "华文行楷"
    
27.           .Bold = True
    
28.         End With
    
29.         .ParagraphFormat.Alignment = wdAlignParagraphLeft
    
30.         .TypeText Text:=arr(i, 2) & "："
    
31.         .TypeParagraph
    
32.         With .Font
    
33.           .Size = 18
    
34.           .Name = "宋体"
    
35.         End With
    
36. '        .Style = ActiveDocument.Styles("正文")
    
37.         .TypeText Text:="你的工资为" & arr(i, 3) & "元。"
    
38.         .TypeParagraph
    
39.         .TypeParagraph
    
40.         .TypeParagraph
    
41.         .TypeText Text:="某公司"
    
42.         .TypeParagraph
    
43.         .TypeText Text:="2011年7月16日"
    
44.         .InsertBreak Type:=0
    
45.       Next
    
46.     End With
    
47.     .ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & "\工资通知"
    
48.     .Quit
    
49.   End With
    
50. End Sub
    

复制代码

chxw68

太晚了，没有写完，明天继续写。

duquancai

不就是简单的邮件合并吗？

duquancai

Sub 邮件合并_wdVBA()
    Dim pf$
    pf = ThisDocument.Path & "\将Excel数据对应写入已做好的Word模板的指定位置(统发).xls"
    With ThisDocument.MailMerge
        .MainDocumentType = wdNotAMergeDocument
        .MainDocumentType = wdFormLetters
        .OpenDataSource Name:=pf, LinkToSource:=True, _
        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=pf;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database=", _
        SQLStatement:="SELECT * FROM `数据$` where 姓名 is not null"
    End With
    With ThisDocument.Content.Find
        Do While .Execute("数据001")
            ThisDocument.MailMerge.Fields.Add .Parent, "姓名"
            .Parent.Collapse 0
        Loop
    End With
    With ThisDocument.Content.Find
        Do While .Execute("数据002")
            ThisDocument.MailMerge.Fields.Add .Parent, "基础工资"
            .Parent.Collapse 0
        Loop
    End With
    With ThisDocument.Content.Find
        Do While .Execute("数据003")
            ThisDocument.MailMerge.Fields.Add .Parent, "奖金"
            .Parent.Collapse 0
        Loop
    End With
    Application.ScreenUpdating = False
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
    Application.ScreenUpdating = True
    With ActiveDocument
        .SaveAs ThisDocument.Path & "\工资通知(希望达到的效果）.docx"
        .Close 0
    End With
    MsgBox "完成并保存！"
End Sub

jiminyanyan

duquancai 发表于 2017-3-4 00:10
不就是简单的邮件合并吗？

通过vba 写入更加灵活

jiminyanyan

chxw68 发表于 2017-3-3 23:40

谢谢老师。

jjmysjg

留下个记号，谢谢楚老师

jsgj2023

jjmysjg 发表于 2017-3-4 07:33
留下个记号，谢谢楚老师

是褚,不是楚!