生成一个子表自动在汇总表上生成一条记录

demonwzr · 发表于 2013-1-10 22:53

我工作上需要建立无数个人的表格（都是一样的模板，B1为姓名，F1为编号，B13为结论）。。。。。。
没建立一个个人表格，在汇总表上自动生成一条记录，如何实现？

ps：个人表的命名规则为那个人的姓名

请各位大师帮忙下，小弟十分感谢。。。。。

汇总.rar (10.98 KB, 下载次数: 14)

zhaogang1960 · 发表于 2013-1-11 00:12

为了简化程序，可在每当汇总表工作簿打开时就自动计算一遍：

Private Sub Workbook_Open()
Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&, t$
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
Sheets("Sheet1").UsedRange.Offset(2).ClearContents
Set cnn = CreateObject("ADODB.Connection")
MyPath = ThisWorkbook.Path & ""
MyFile = Dir(MyPath & "*.xls")
Do While MyFile <> ""
If MyFile <> ThisWorkbook.Name Then
n = n + 1
If n = 1 Then
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
Else
t = "[Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "]."
End If
m = m + 1
If m > 49 Then
Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
m = 1
SQL = ""
End If
If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "select '" & Replace(MyFile, ".xls", "") & "',f1 from " & t & "[Sheet1$b13:b13]"
End If
MyFile = Dir()
Loop
If Len(SQL) Then Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
[a3] = 1
m = [b65536].End(xlUp).Row
If m > 3 Then [a3].AutoFill Destination:=Range("A3:A" & m), Type:=xlFillSeries
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2013-1-11 00:14

请看附件

汇总.rar (18.5 KB, 下载次数: 25)

demonwzr · 发表于 2013-1-11 08:33

zhaogang1960 发表于 2013-1-11 00:14
请看附件

谢谢，十分感谢，要是我想收集个人表中更多数据的话，需要改的是哪段话，是不是If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "select '" & Replace(MyFile, ".xls", "") & "',f1 from " & t & "[Sheet1$b13:b13]"
End If
这段啊

zhaogang1960 · 发表于 2013-1-11 10:51

demonwzr 发表于 2013-1-11 08:33
谢谢，十分感谢，要是我想收集个人表中更多数据的话，需要改的是哪段话，是不是If Len(SQL) Then SQL = S ...

由于要收集的数据不在一起，不能简单地修改SQL语句，容我想想

zhaogang1960 · 发表于 2013-1-11 11:24

demonwzr 发表于 2013-1-11 08:33
谢谢，十分感谢，要是我想收集个人表中更多数据的话，需要改的是哪段话，是不是If Len(SQL) Then SQL = S ...

假设你想收集的数据是：姓名结论血压

Private Sub Workbook_Open()
Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&, t$
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
Sheets("Sheet1").UsedRange.Offset(2).ClearContents
Set cnn = CreateObject("ADODB.Connection")
MyPath = ThisWorkbook.Path & ""
MyFile = Dir(MyPath & "*.xls")
Do While MyFile <> ""
If MyFile <> ThisWorkbook.Name Then
n = n + 1
If n = 1 Then
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
Else
t = "[Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "]."
End If
m = m + 1
If m > 49 Then
Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
m = 1
SQL = ""
End If
If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "select top 1 '" & Replace(MyFile, ".xls", "") & "',(select f1 from " & t & "[Sheet1$b13:b13]),(select f1 from " & t & "[Sheet1$d9:d9]) from " & t & "[Sheet1$]"
End If
MyFile = Dir()
Loop
If Len(SQL) Then Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
[a3] = 1
m = [b65536].End(xlUp).Row
If m > 3 Then [a3].AutoFill Destination:=Range("A3:A" & m), Type:=xlFillSeries
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2013-1-11 11:25

请看附件

汇总.rar (17.22 KB, 下载次数: 38)

LMY123 · 发表于 2018-8-29 17:51

t = "[Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "]."

iwangyi · 发表于 2018-8-29 20:42

太强大了-------

		自动登录	找回密码
密码			免费注册

[求助] 生成一个子表自动在汇总表上生成一条记录

评分

评分