【83期】VBA多工作簿多工作表数据查询[已小结]

29151429 · 发表于 2015-1-22 20:44

跟帖详细学习

jpj123 · 发表于 2015-2-8 23:25

今天学习了下，改进了下某老师的代码，不再循环各字段写入数据!

Public Sub BBBBBBBBBBB()
'On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim t As Date, ne$, rs%, i%, ii%, Name$, FName$, pa, sql, n%, m%, n2%, x%
Dim arr(1 To 9999)
Dim rst As ADODB.Recordset
Dim cnn As ADODB.Connection
ne = [c2]: i = 0: rs = 3
t = Timer
Name = ThisWorkbook.Name
Range("a4:h" & [h65536].End(3).Row + 1).ClearContents
FName = Dir(ThisWorkbook.Path & "\*.xls")
Do Until FName = "" ' ThisWorkbook.Name
If FName <> Name Then
i = i + 1
arr(i) = FName
End If
FName = Dir
Loop
For ii = 1 To i
n = 0: m = 0
Set cnn = New ADODB.Connection
pa = ThisWorkbook.Path & "" & arr(ii)
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;HDR=YES';data source=" & pa
For x = 1 To 3
Set rst = New ADODB.Recordset
sql = "select * from [" & x & "部门$A3:F] where 姓名 like '%" & ne & "%'"
Err.Clear
rst.Open sql, cnn, 1, 3
With Sheet1
n = .Cells(65536, 1).End(xlUp).Row + 1
m = .UsedRange.Columns.Count
.Cells(n, 1).CopyFromRecordset rst
n2 = .Cells(65536, 1).End(xlUp).Row + 1
If n <> n2 Then
.Range(.Cells(n, m - 1), .Cells(n2 - 1, m - 1)) = Left(arr(ii), Len(arr(ii)) - 4)
.Range(.Cells(n, m), .Cells(n2 - 1, m)) = x & "部门"
End If
End With
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒！" & Chr(10) & "共有“" & [a65536].End(3).Row - 3 & "”条记录！", vbInformation, "完工"
End Sub

复制代码

zhaogang1960 · 发表于 2015-2-10 00:29

jpj123 发表于 2015-2-8 23:25
今天学习了下，改进了下某老师的代码，不再循环各字段写入数据!

效果很好，60多个数据源共计180多个工作表都要复制一次数据，违反了本题目”复制数据次数不超过5次“的规则，本题本身很简单，出题目的在于测试当多于49个工作表时，处理SQL联合查询的方法

jpj123 · 发表于 2015-2-10 00:39

zhaogang1960 发表于 2015-2-10 00:29
效果很好，60多个数据源共计180多个工作表都要复制一次数据，违反了本题目”复制数据次数不超过5次“的规 ...

首选感谢赵版的点评，昨天看了一老师的代码，只是觉得各字段循环赋值太麻烦了，也很费时间，(从帖子中间看的，没注意要求)所以就动手改了下。时限早过了，赵版还给我点评，再次感谢，呵呵!

zhongchangliang · 发表于 2015-11-3 14:54

帖子过去好久了啊，刚接触ADO,上传答案仅供同是菜鸟的朋友参考下，运行速度比数组法快，比高手的代码慢3秒左右，若是赵老师看到了，希望可以解释下SQL1、SQL2两句代码合并成1句如何实现相同的效果，同样欢迎高手解答。

Sub 查询()
Dim SQL1, SQL2, i, T
Dim Rg As Range
Dim Conn As Object
Dim MyPath$, MyName$
T = Timer
Range("a4:H10000") = ""
Set Conn = CreateObject("adodb.connection")
MyPath = ThisWorkbook.Path
MyName = Dir(MyPath & "\*.xls")
Application.ScreenUpdating = False
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & MyPath & "" & MyName
For i = 1 To 3
SQL1 = "select * from [Excel 8.0;DATABASE=" & MyPath & "" & MyName & "].[" & i & "部门$A3:F200] where 姓名 = '" & Range("c2").Value & "'"
SQL2 = "select """ & Left(MyName, 6) & """,""" & i & "部门"" from [Excel 8.0;DATABASE=" & MyPath & "" & MyName & "].[" & i & "部门$A3:F200] where 姓名 = '" & Range("c2").Value & "'"
Debug.Print Sql
Set Rg = Range("a65535").End(xlUp).Offset(1)
Rg.CopyFromRecordset Conn.Execute(SQL1) '[" & i & "部门$A3:F200] 引用的工作表数据从第三行开始，所以要加上数据区域
Rg.Offset(, 6).CopyFromRecordset Conn.Execute(SQL2)
Next
Conn.Close '关闭当前对象
End If
MyName = Dir
Loop
Set Conn = Nothing '程序运行结束后清空Conn对象
Application.ScreenUpdating = True
MsgBox "耗时" & Timer - T & "秒"
End Sub

复制代码

fgwei · 发表于 2015-12-5 09:29

谢谢，很强大！！！！！

liuyizhong · 发表于 2016-5-13 22:07

19楼的附件不能下载了

jsgj2023 · 发表于 2016-7-1 17:16

占位学习。谢谢各位老师的分享。

weiyingde · 发表于 2016-9-14 15:02

这样的学习式研讨，比武式的展示，直叫我们这样菜鸟傻眼，让我们感受到思想的活力，才智的美妙

hefuqing · 发表于 2017-1-8 16:28

赵老师你好我下载了代码但是现在的格式都是xlsx格式的，我借用了代码，运行错误。不知道怎么修改。可以帮忙指点下吗

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

[Excel 程序开发] 【83期】VBA多工作簿多工作表数据查询[已小结]