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

demonwzr

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


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

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

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

2013-1-10 22:53 上传

点击文件名下载附件

zhaogang1960

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

1. Private Sub Workbook_Open()
   
2.     Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&, t$
   
3.     Application.ScreenUpdating = False
   
4.     Sheets("Sheet1").Activate
   
5.     Sheets("Sheet1").UsedRange.Offset(2).ClearContents
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     MyPath = ThisWorkbook.Path & ""
   
8.     MyFile = Dir(MyPath & "*.xls")
   
9.     Do While MyFile <> ""
   
10.         If MyFile <> ThisWorkbook.Name Then
    
11.             n = n + 1
    
12.             If n = 1 Then
    
13.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
    
14.             Else
    
15.                 t = "[Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "]."
    
16.             End If
    
17.             m = m + 1
    
18.             If m > 49 Then
    
19.                 Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
20.                 m = 1
    
21.                 SQL = ""
    
22.             End If
    
23.             If Len(SQL) Then SQL = SQL & " union all "
    
24.             SQL = SQL & "select '" & Replace(MyFile, ".xls", "") & "',f1 from " & t & "[Sheet1$b13:b13]"
    
25.         End If
    
26.         MyFile = Dir()
    
27.     Loop
    
28.     If Len(SQL) Then Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
29.     [a3] = 1
    
30.     m = [b65536].End(xlUp).Row
    
31.     If m > 3 Then [a3].AutoFill Destination:=Range("A3:A" & m), Type:=xlFillSeries
    
32.     cnn.Close
    
33.     Set cnn = Nothing
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

zhaogang1960

请看附件
汇总.rar (18.5 KB, 下载次数: 25)

2013-1-11 00:14 上传

点击文件名下载附件

demonwzr

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

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

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

zhaogang1960

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

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

1. Private Sub Workbook_Open()
   
2.     Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&, t$
   
3.     Application.ScreenUpdating = False
   
4.     Sheets("Sheet1").Activate
   
5.     Sheets("Sheet1").UsedRange.Offset(2).ClearContents
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     MyPath = ThisWorkbook.Path & ""
   
8.     MyFile = Dir(MyPath & "*.xls")
   
9.     Do While MyFile <> ""
   
10.         If MyFile <> ThisWorkbook.Name Then
    
11.             n = n + 1
    
12.             If n = 1 Then
    
13.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
    
14.             Else
    
15.                 t = "[Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "]."
    
16.             End If
    
17.             m = m + 1
    
18.             If m > 49 Then
    
19.                 Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
20.                 m = 1
    
21.                 SQL = ""
    
22.             End If
    
23.             If Len(SQL) Then SQL = SQL & " union all "
    
24.             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$]"
    
25.         End If
    
26.         MyFile = Dir()
    
27.     Loop
    
28.     If Len(SQL) Then Range("b65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
29.     [a3] = 1
    
30.     m = [b65536].End(xlUp).Row
    
31.     If m > 3 Then [a3].AutoFill Destination:=Range("A3:A" & m), Type:=xlFillSeries
    
32.     cnn.Close
    
33.     Set cnn = Nothing
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

zhaogang1960

请看附件
汇总.rar (17.22 KB, 下载次数: 38)

2013-1-11 11:25 上传

点击文件名下载附件

LMY123

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

iwangyi

太强大了-------