求助数据按模板拆分填充，类似邮件合并

riauxk

求助老师，附件中，想将数据按模板拆分填入，再生成单个工作簿，请指点，感谢！

EXCELLMY

11年的老会员提这个问题，难度太小，基本无解

riauxk

EXCELLMY 发表于 2019-12-27 12:15
11年的老会员提这个问题，难度太小，基本无解

真是惭愧，磨了几天搞不定，上来求老师。

EXCELLMY

riauxk 发表于 2019-12-27 12:25
真是惭愧，磨了几天搞不定，上来求老师。

http://club.excelhome.net/thread-1407531-1-1.html

riauxk

EXCELLMY 发表于 2019-12-27 14:23
http://club.excelhome.net/thread-1407531-1-1.html

这个看过了，就是对不准，导不出，也想弄打印和导出图片格式

EH2003

1. Sub yy()
   
2. 
   
3. arr = Sheet2.[a1].CurrentRegion
   
4. For i = 4 To UBound(arr)
   
5.        Set whor = Workbooks.Open(ThisWorkbook.Path & "\模板.xlsx")
   
6.         With whor.Sheets("模板")
   
7. '        .[c2] = arr(i, 1)
   
8.         .[f2] = arr(i, 2)
   
9.         .[d4] = arr(i, 3)
   
10.         .[e4] = arr(i, 4)
    
11.         .[f4] = arr(i, 5)
    
12.         .[g4] = arr(i, 6)
    
13.         .[d5] = arr(i, 7)
    
14.         .[e5] = arr(i, 8)
    
15.         .[f5] = arr(i, 9)
    
16.         .[g5] = arr(i, 10)
    
17.         .[d6] = arr(i, 11)
    
18.         .[e6] = arr(i, 12)
    
19.         .[f6] = arr(i, 13)
    
20.         .[g6] = arr(i, 14)
    
21.         .[d7] = arr(i, 15)
    
22.         .[e7] = arr(i, 16)
    
23.         .[f7] = arr(i, 17)
    
24.         .[g7] = arr(i, 18)
    
25.         .[d8] = arr(i, 19)
    
26.         .[e8] = arr(i, 20)
    
27.         .[f8] = arr(i, 21)
    
28.         .[g8] = arr(i, 22)
    
29.         .[d9] = arr(i, 23)
    
30.         .[e9] = arr(i, 24)
    
31.         .[f9] = arr(i, 25)
    
32.         .[g9] = arr(i, 26)
    
33.         .[d10] = arr(i, 27)
    
34.         .[e10] = arr(i, 28)
    
35.         .[f10] = arr(i, 29)
    
36.         .[g10] = arr(i, 30)
    
37.         .[d11] = arr(i, 31)
    
38.         .[e11] = arr(i, 32)
    
39.         .[f11] = arr(i, 33)
    
40.         .[g11] = arr(i, 34)
    
41.         .[d12] = arr(i, 35)
    
42.         .[e12] = arr(i, 36)
    
43.         .[f12] = arr(i, 37)
    
44.         .[g12] = arr(i, 38)
    
45.         .[d13] = arr(i, 39)
    
46.         .[e13] = arr(i, 40)
    
47.         .[f13] = arr(i, 41)
    
48.         .[g13] = arr(i, 42)
    
49.         .[d14] = arr(i, 43)
    
50.         .[e14] = arr(i, 44)
    
51.         .[f14] = arr(i, 45)
    
52.         .[g14] = arr(i, 46)
    
53.         .[d15] = arr(i, 47)
    
54.         .[e15] = arr(i, 48)
    
55.         .[f15] = arr(i, 49)
    
56.         .[g15] = arr(i, 50)
    
57.         .[c16] = arr(i, 53)
    
58.         .[c17] = arr(i, 54)
    
59.         .[e17] = arr(i, 55)
    
60.         .[g17] = arr(i, 56)
    
61.         .[c18] = arr(i, 57)
    
62.         .[f18] = arr(i, 58)
    
63.         .[b19] = arr(i, 59)
    
64.         .[b21] = arr(i, 60)
    
65.         For ii = 4 To 15
    
66.         If Cells(ii, 4) = "" Then Cells(ii, 1) = ""
    
67.         Next ii
    
68.         .SaveAs ThisWorkbook.Path & "\文件" & arr(i, 2) & ".xlsx"
    
69.         End With
    
70.         whor.Close 1
    
71.     Next i
    
72. End Sub

复制代码

EH2003

数据及模板附件.zip (41.58 KB, 下载次数: 67)

2019-12-27 17:04 上传

点击文件名下载附件

EH2003

试试行不行？

riauxk

EH2003 发表于 2019-12-27 17:01

感谢，
追问，能否直接利用附件里面的模板-Sheet1(模板)，生成的文件再直接转为PDF？

riauxk

EH2003 发表于 2019-12-27 17:01

感谢，
能否直接利用工作簿里面的模板 Sheet1(模板)，再生成导出为PDF格式的