EXCEl Home的大拿，快来帮帮我！

banlc

小型建筑        需要安装        不需要安装的        建筑安装        其他费用        预备费        总价值
工程费        的设备费        设备、工器具费        工程费                       


预算汇总表-昌北区，需要从单项工程汇总表的A1表，提取以上费用！
仅列举了5张表，实际工作中有好几百张！

zhaogang1960

请参考：

1. Sub ADO加数组法()
   
2.     Dim cnn As Object, SQL$, p$, f$, a, arr, brr#(), i&, j&, n&
   
3.     arr = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
   
4.     ReDim brr(1 To UBound(arr), 0 To 6)
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     For i = 1 To UBound(arr)
   
8.         f = p & arr(i, 1) & "" & arr(i, 1) & "【汇总预算】.xls"
   
9.         If Dir(f) <> "" Then
   
10.             n = n + 1
    
11.             If n = 1 Then cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & f
    
12.             SQL = "select * from [Excel 12.0;hdr=no;Database=" & f & "].[A1$D15:J15]"
    
13.             a = cnn.Execute(SQL).GetRows
    
14.             For j = 0 To 6
    
15.                 If Not IsNull(a(j, 0)) Then brr(i, j) = a(j, 0)
    
16.             Next
    
17.         End If
    
18.     Next
    
19.     [b3].Resize(i - 1, 7) = brr
    
20.     cnn.Close
    
21.     Set cnn = Nothing
    
22. End Sub
    

复制代码

zhaogang1960

请测试附件
求助资料.rar (392.85 KB, 下载次数: 78)

2016-1-13 16:00 上传

点击文件名下载附件

banlc

谢谢大拿，不过好像这个代码只能查找18行，多了就不行！

chenbiao2012

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Dim brr(1 To 1000, 1 To 8)
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     For Each fs In fso.getfolder(ThisWorkbook.Path & "").subfolders
   
6.         f = Dir(fs & "\*.xls*")
   
7.         Do While f <> ""
   
8.             If f <> ThisWorkbook.Name Then
   
9.                 If InStr(f, "汇总") Then
   
10.                     With GetObject(fs & "" & f)
    
11.                         With .Sheets("A1")
    
12.                             Set Rng = .Cells.Find("总计", , , 1)
    
13.                             If Not Rng Is Nothing Then
    
14.                                 r = Rng.Row
    
15.                                 arr = .Cells(r, 4).Resize(, 7)
    
16.                                 n = n + 1
    
17.                                 brr(n, 1) = Split(f, "【")(0)
    
18.                                 For j = 2 To 8
    
19.                                     brr(n, j) = arr(1, j - 1)
    
20.                                 Next
    
21.                             End If
    
22.                         End With
    
23.                         .Close 0
    
24.                     End With
    
25.                 End If
    
26.             End If
    
27.             f = Dir
    
28.         Loop
    
29.         Set fs = Nothing
    
30.     Next
    
31.     With Sheets("sheet1")
    
32.         .UsedRange.Offset(2).ClearContents
    
33.         .[a3].Resize(n, 8) = brr
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

chenbiao2012

但是这样肯定不如sql快

banlc

chenbiao2012 发表于 2016-1-13 22:43
但是这样肯定不如sql快

你这个代码我用不了，不过还是谢谢！

LMY123

ado 加数组
For Each fs In fso.getfolder(ThisWorkbook.Path & "\").subfolders