关于数据自动引入模板并拆分保存问题

tomcrs

希望表格增加输入框，当输入如201801至201810后自动把201801至201810的编号单个填写到模板，并另存名为201801至201810的10个模板格式文件
（保存分割后的模板表格内保持引入的数值而不是函数）

tomcrs

下午人少？

tomcrs

麻烦各位大侠帮下忙！

tomcrs

没人会吗？

tomcrs

没人吗？麻烦大家帮助我下  

LMY123

tomcrs 发表于 2018-7-31 08:38
没人吗？麻烦大家帮助我下

1. 'Option Explicit
   
2. Sub ado_一行一薄B()
   
3. Dim sh As Worksheet
   
4. Application.DisplayAlerts = False: Application.ScreenUpdating = False
   
5. Dim cnn, rs, sql$: Set cnn = CreateObject("adodb.connection"): Set rs = CreateObject("adodb.Recordset")
   
6.   cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source =" & ThisWorkbook.Path & "\数据库.xlsx"
   
7. sql = "select * from [sheet1$A2:J11]"
   
8. rs.Open sql, cnn, 1, 1
   
9. On Error Resume Next
   
10. Do While Not rs.EOF
    
11.         Workbooks.Add
    
12.         ThisWorkbook.Sheets(1).Rows("1:8").Copy [a1]
    
13.         ThisWorkbook.Sheets(1).Columns("A:G").Copy [a1]
    
14.         [B2] = rs.Fields(0)
    
15.         [B3] = rs.Fields(1)
    
16. '        [I2] = rs.Fields(2)
    
17. '        [N2] = rs.Fields(3)
    
18. '        [A3] = rs.Fields(4)
    
19. '        [J3] = rs.Fields(5)
    
20. '        [A4] = rs.Fields(6)
    
21. '        [F4] = rs.Fields(7)
    
22. '        [K4] = rs.Fields(8)
    
23. '        [R4] = rs.Fields(9)
    
24.         ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\拆分后文件存放处" & rs.Fields(0)
    
25.         ActiveWorkbook.Close
    
26.     rs.MoveNext
    
27. Loop
    
28. rs.Close: cnn.Close: Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
29. End Sub

复制代码

tomcrs

LMY123 发表于 2018-7-31 15:40

非常感谢！能否出个输入框 点击1到多少  就分拆1到多少

tomcrs

拆分是可以 但没有输入框啊