【急！】如何从一个Excel表中提取数据，自动填入指定模板，生成多个Excel文件？

魂断蓝桥

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    If sh.Name <> "薪酬变动申请表" Then
        sh.Delete
    End If
Next
Dim cnn, rs, sql$
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\人员汇总表.xlsx"
sql = "select * from [sheet1$A1:f] where 姓名 is not null"
rs.Open sql, cnn, 1, 1
Do While Not rs.EOF
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheet1.Rows("1:50").Copy [a1]
        Sheet1.Columns("a:g").Copy [a1]
        [a7] = rs.Fields(0)
        [d7] = rs.Fields(1)
        [a9] = rs.Fields(2)
        [c9] = rs.Fields(3)
        [c16] = rs.Fields(4)
        [d16] = rs.Fields(5)
        ActiveSheet.Name = rs.Fields(0)
    rs.MoveNext
Loop
rs.Close
cnn.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

魂断蓝桥

拆分到工作簿

Option Explicit

Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim cnn, rs, sql$
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\人员汇总表.xlsx"
sql = "select * from [sheet1$A1:f] where 姓名 is not null"
rs.Open sql, cnn, 1, 1
Do While Not rs.EOF
        Workbooks.Add
        ThisWorkbook.Sheets(1).Rows("1:50").Copy [a1]
        ThisWorkbook.Sheets(1).Columns("a:g").Copy [a1]
        [a7] = rs.Fields(0)
        [d7] = rs.Fields(1)
        [a9] = rs.Fields(2)
        [c9] = rs.Fields(3)
        [c16] = rs.Fields(4)
        [d16] = rs.Fields(5)
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & rs.Fields(0)
        ActiveWorkbook.Close
    rs.MoveNext
Loop
rs.Close
cnn.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

我是么么茶

蔡明江 发表于 2017-1-22 12:33
思路有问题 模板表本来就应该和人员汇总表放到一个工作簿中以便操作

有问题可以调整，盼赐教~~~

我是么么茶

一分结界 发表于 2017-1-22 12:40
这种需求也就偶尔用一次，做出来还费劲，没人愿意花力气搞这个的，

这个需要花大力气的我也知道，可是还是盼着一点希望来求助一下，主要是数量大，每个复制粘贴还不能错， 也许对于我来说是比较难的，可能对于某些人来说相比较而言是稍微容易点的

meiok

魂断蓝桥 发表于 2017-1-22 12:48
拆分到工作簿

Option Explicit

http://club.excelhome.net/forum. ... ead&tid=1190455

我是么么茶

魂断蓝桥 发表于 2017-1-22 12:48
拆分到工作簿

Option Explicit

我试了一下，完全没问题，真的非常感谢您，谢谢，谢谢，收到陌不相识的你的热心帮忙，我都感动快哭了，谢谢你帮我解决一个大难题，省了不少时间，还是好人多哈~~~

lzqmsy

打印人员汇总表.rar (18.36 KB, 下载次数: 868)

2017-1-23 00:29 上传

点击文件名下载附件

做着玩,希望你有用

我是么么茶

lzqmsy 发表于 2017-1-23 00:29
做着玩,希望你有用

谢谢哈，我的问题已经解决了，不过还是谢谢热心的你哈，O(∩_∩)O谢谢！

yuyonglian

做个记号，明天学习一下。

whqspeng

记号，学习