如何提取不同文件夹里同名excel文档里的信息

rmajly

opiona 发表于 2015-5-21 17:00

其实这段代码也不错，速度似乎更快。可惜有几个问题我没有法子解决。

1. Private Sub 按钮8_单击()
   
2.     Dim arr()
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     [B29:O100].ClearContents
   
7.     Mypath = ThisWorkbook.Path & ""
   
8.     MyName = Dir(Mypath, vbDirectory)
   
9.     Do While MyName <> ""
   
10.         If MyName <> "." And MyName <> ".." Then
    
11.             If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then
    
12.                 m = m + 1
    
13.                 ReDim Preserve arr(m)
    
14.                 arr(m) = Mypath & MyName & ""
    
15.             End If
    
16.         End If
    
17.         MyName = Dir
    
18.     Loop
    
19.     h = 29
    
20.     For k = 1 To m
    
21.         f = Dir(arr(k) & "*.xls")
    
22.         Do While f > " "
    
23.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & arr(k) & f
    
24.             Sql = "select * from [sheet1$aj4:aj4]"
    
25.             Cells(h, 2).CopyFromRecordset cnn.Execute(Sql)
    
26.             Sql = "select * from [sheet1$aj5:aj5]"
    
27.             Cells(h, 5).CopyFromRecordset cnn.Execute(Sql)
    
28.             Sql = "select * from [sheet1$aj6:aj6]"
    
29.             Cells(h, 6).CopyFromRecordset cnn.Execute(Sql)
    
30.             Sql = "select * from [sheet1$aj7:aj7]"
    
31.             Cells(h, 8).CopyFromRecordset cnn.Execute(Sql)
    
32.             Sql = "select * from [sheet5$h9:h9]"
    
33.             Cells(h, 15).CopyFromRecordset cnn.Execute(Sql)
    
34.             Cells(h, 12) = Now()
    
35.              h = h + 1
    
36.             cnn.Close
    
37.             f = Dir
    
38.         Loop
    
39.     Next
    
40.         Application.DisplayAlerts = True
    
41.     Application.ScreenUpdating = True
    
42. End Sub
    

复制代码

jjmysjg

实很,非常感谢

opiona

rmajly 发表于 2015-5-21 21:06
其实这段代码也不错，速度似乎更快。可惜有几个问题我没有法子解决。

SQL方法的汇总查询
完整代码见附件

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona2()  '//这个速度快，是因为不用打开Excel
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. t = Timer   '//开始时间
    
13. 
    
14.     Set SH0 = Worksheets("Sheet2")
    
15.     SH0.Range("B29:R65536").ClearContents
    
16.    
    
17.     FileArr = FileAllArr(ThisWorkbook.Path, "档案M.xls", ThisWorkbook.Name, False)
    
18.     For I = 0 To UBound(FileArr)
    
19.         Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO;imex=1';Data Source=" & FileArr(I)    '//OFFICE2003
    
20.         StrSQL = "SELECT * FROM [Sheet1$H1:AJ7]"
    
21.         SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
22.         
    
23.         SH0.Cells(I + 29, 2) = SQLARR(3, 28)
    
24.         If InStr(SQLARR(0, 0), "√") > 0 Then SH0.Cells(I + 29, 4) = "男"
    
25.         If InStr(SQLARR(0, 2), "√") > 0 Then SH0.Cells(I + 29, 4) = "女"
    
26.         SH0.Cells(I + 29, 5) = SQLARR(4, 28) & "岁"
    
27.         SH0.Cells(I + 29, 6) = SQLARR(5, 28)
    
28.         SH0.Cells(I + 29, 8) = SQLARR(6, 28)
    
29.         SH0.Cells(I + 29, 12) = Format(Now, "YYYY-MM-DD")
    
30.         
    
31.         StrSQL = "SELECT * FROM [Sheet5$H9:H9]"
    
32.         SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
33.         SH0.Cells(I + 29, 15) = SQLARR(0, 0)
    
34.     Next
    
35. 
    
36. Application.ScreenUpdating = True '//恢复屏幕刷新
    
37. Application.DisplayAlerts = True '//恢复系统提示
    
38. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
39. End Sub

复制代码

opiona

aaa.rar (95.46 KB, 下载次数: 17)

2015-5-24 09:44 上传

点击文件名下载附件

两种方法都在模块代码中

rmajly

opiona 发表于 2015-5-24 09:45
两种方法都在模块代码中

opiona大哥，太崇拜你了！送花两朵表示谢意，非常感谢！

LMY123

ADO多夹同名工作薄合并成一薄表