根据excel数据和word模板生成word

toc230415

各位大佬，本人想做一个根据word模板和excel的数据生成多页WORD的VB代码，每行数据生成一页WORD（生成的数据都在一个WORD内只是不同页），可是我做好后不论怎么调整都有问题，目前的问题是只有第一页能生成但是内容也不是excel内一行的内容，请大佬帮忙修改或者重新做一个，谢谢！

wengjl

一行生一张sheet表，不就简单了

toc230415

wengjl 发表于 2024-8-20 10:21
一行生一张sheet表，不就简单了

这些是需要打印出来签到的，一张一个sheet不好打印啊

wengjl

toc230415 发表于 2024-8-20 10:33
这些是需要打印出来签到的，一张一个sheet不好打印啊

VBA是可以直接生成+打印的

用不着你再打开表去点打印的

jaxxcyh

循环中少了填表前先备份模板内容页的命令，导致处理了一条记录后，模板里的查找值不存在了，后面的记录也没法继续处理

jaxxcyh

程序流程应该是：
循环头
发现一条记录
复制模板到下一页
在新页面模板里填写记录
循环尾

模板内容放在第一页一直保留。

zhlt8888

只插入分页符能行？
循环只是替换了第一页，其他页没东西怎么替换？
不知道我看的对不对，我是新手

lizhipei78

https://club.excelhome.net/threa ... tml?_dsign=141af79a

Yalishanda30

e..........

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim mypath, myname
   
5.     Dim wordapp As Object
   
6.     If Dir(ThisWorkbook.Path & "\培训记录模板.docx") = "" Then
   
7.         MsgBox ThisWorkbook.Path & "\培训记录模板.docx不存在！"
   
8.         Exit Sub
   
9.     End If
   
10.     With Worksheets("sheet1")
    
11.         .AutoFilterMode = False
    
12.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         arr = .Range("a2:j" & r)
    
14.     End With
    
15.     Set wordapp = CreateObject("word.application")
    
16.     wordapp.Visible = True
    
17.     Set mydoc = wordapp.Documents.Open(ThisWorkbook.Path & "\培训记录模板.docx")
    
18.     With mydoc
    
19.         .tables(1).Select
    
20.         wordapp.Selection.MoveDown wdLine, 1, wdMove
    
21.         wordapp.Selection.EndKey wdStory, wdExtend
    
22.         wordapp.Selection.Delete
    
23.         .tables(1).Select
    
24.         wordapp.Selection.MoveUp wdLine, 1, wdMove
    
25.         wordapp.Selection.EndKey wdLine, wdExtend
    
26.         wordapp.Selection.End = .tables(1).Range.End
    
27.         wordapp.Selection.Copy
    
28.         For i = 1 To UBound(arr) - 1
    
29.             With .Paragraphs.Last.Range
    
30.                 .InsertParagraphAfter
    
31.                 .Paste
    
32.             End With
    
33.         Next
    
34.         For i = 1 To UBound(arr)
    
35.             With .tables(i)
    
36.                 .Cell(1, 2).Range.Text = arr(i, 9)
    
37.                 .Cell(1, 4).Range.Text = arr(i, 4)
    
38.                 .Cell(2, 2).Range.Text = arr(i, 2)
    
39.                 .Cell(3, 2).Range.Text = arr(i, 3)
    
40.                 .Cell(4, 2).Range.Text = arr(i, 5)
    
41.                 .Cell(4, 4).Range.Text = arr(i, 8)
    
42.                 .Cell(5, 2).Range.Text = arr(i, 7)
    
43.                 .Cell(5, 4).Range.Text = arr(i, 10)
    
44.                 .Cell(6, 2).Range.Text = arr(i, 6)
    
45.             End With
    
46.         Next
    
47.         .SaveAs2 ThisWorkbook.Path & "\培训记录.docx"
    
48.         .Close
    
49.     End With
    
50.     wordapp.Quit
    
51.     MsgBox "培训记录生成完毕！"
    
52. End Sub
    

复制代码