请问如何将一个Excel表的内容填入另一个固定的模板中？

LMY123

ghostmale 发表于 2018-6-25 15:37
额，谢谢，其实就想那个大神举个例子填一个就行，别的我依样画葫芦填好~

1. Option Explicit
   
2. 
   
3. Sub ADO_一行一模板()
   
4. Dim sh As Worksheet
   
5. Application.DisplayAlerts = False
   
6. Application.ScreenUpdating = False
   
7. Dim cnn, rs, sql$
   
8. Set cnn = CreateObject("adodb.connection")
   
9. Set rs = CreateObject("adodb.Recordset")
   
10. cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\代维电池放电测试站点汇总.xlsx"
    
11. sql = "select * from [sheet1$B1:L] where 站名 is not null"
    
12. rs.Open sql, cnn, 1, 1
    
13. Do While Not rs.EOF
    
14.         Workbooks.Add
    
15.         ThisWorkbook.Sheets(1).Rows("1:50").Copy [A1]
    
16.         ThisWorkbook.Sheets(1).Columns("A:L").Copy [A1]
    
17.         [A2] = rs.Fields(1)
    
18.         [E2] = rs.Fields(0)
    
19.         [I2] = rs.Fields(2)
    
20.         [N2] = rs.Fields(3)
    
21.         [A3] = rs.Fields(4)
    
22.         [J3] = rs.Fields(5)
    
23.         [A4] = rs.Fields(6)
    
24.         [F4] = rs.Fields(7)
    
25.         [K4] = rs.Fields(8)
    
26.         [R4] = rs.Fields(9)
    
27.         ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & rs.Fields(0)
    
28.         ActiveWorkbook.Close
    
29.     rs.MoveNext
    
30. Loop
    
31. rs.Close
    
32. cnn.Close
    
33. Application.ScreenUpdating = True
    
34. Application.DisplayAlerts = True
    
35. End Sub
    

复制代码

opiona

1.     PathG = ThisWorkbook.Path & "\合同生成"  '//结果文件夹
   
2.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
3.     If FSO.FolderExists(PathG) = True Then
   
4.         FSO.GetFolder(PathG).Delete   '//删除文件夹
   
5.     End If
   
6.     MkDir PathG    '//创建文件夹
   
7.     Set SHX = Worksheets("合同信息")
   
8.     PATHM = ThisWorkbook.Path & "\模板.XLSX"  '//外部模板
   
9.     Rem  模板中放置数据的单元格位置，和查询标题对应
   
10.     BRX = Split("C8,L8,L9", ",")
    
11.     CRX = Split("5,1,3", ",")
    
12.     BRX2 = Split("C12,L12", ",")
    
13.     CRX2 = Split("6,7", ",")
    
14.     LASTROW = SHX.Range("A65536").End(3).Row
    
15.     For IROW = 2 To LASTROW '//循环每一个值
    
16.         Rem  提示信息，在状态栏显示
    
17.         Application.StatusBar = "需拆分总数：" & LASTROW - 1 & " 个，当前是第：" & IROW - 1 & " 个，当前身份证号码是：" & SHX.Cells(IROW, 1).Value
    
18.         DoEvents
    
19.         Set WB = Workbooks.Open(PATHM)  '//Workbooks.add
    
20.         Set SHW = WB.Worksheets("合同付款进度表")
    
21.         For X = 0 To UBound(BRX)
    
22.             SHW.Range(BRX(X)).Value = SHX.Cells(IROW, Val(CRX(X))).Value
    
23.         Next
    
24.         Set SHW = WB.Worksheets("付款申请单（打印）")
    
25.         For X = 0 To UBound(BRX2)
    
26.             SHW.Range(BRX2(X)).Value = SHX.Cells(IROW, Val(CRX2(X))).Value
    
27.         Next
    
28.         WB.SaveAs Filename:=PathG & "" & SHX.Cells(IROW, 1).Value & ".XLSX", FileFormat:=xlWorkbookDefault    '//保存格式：xls =xlExcel8
    
29.         WB.Close True
    
30.     Next

复制代码

opiona

QQ14885553.rar (50.06 KB, 下载次数: 356)

2018-6-25 18:11 上传

点击文件名下载附件

ghostmale

opiona 发表于 2018-6-25 18:12

非常感谢，我会好好学习您的代码的