ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
楼主: zhaogang1960

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-11-3 17:06 | 显示全部楼层
本帖已被收录到知识树中,索引项:工作表和工作簿
本帖最后由 gufengaoyue 于 2011-11-3 17:09 编辑

{:soso_e195:}

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 3财富 +30 鲜花 +3 技术 +1 收起 理由
小行星B612 + 2 太强大了
231943361 + 1 优秀作品
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-4 08:45 | 显示全部楼层
本帖最后由 panan123_0 于 2011-11-4 09:51 编辑

我也交个试试,循环的优点绕。还望海涵。初学者。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +50 技术 +2 收起 理由
zhaogang1960 + 50 + 2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-4 18:19 | 显示全部楼层
好不容易做出来。但速度还是不行

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-5 11:50 | 显示全部楼层
本帖最后由 zhangjimfu 于 2011-11-12 07:35 编辑

  1. Sub WorkbooksSheetsTotalADO()

  2.     Dim rst, rst2, cnn, sql, myPath$, myFile$, sRow As Single
  3.     myPath = ThisWorkbook.Path & ""
  4.     myFile = Dir(myPath & "*.xls")
  5.     Set rst = CreateObject("ADODB.Recordset")
  6.     Set cnn = CreateObject("ADODB.Connection")
  7.     Application.ScreenUpdating = False
  8.    
  9.     Range("a4:h600").ClearContents
  10.     While myFile <> ""
  11.         sRow = WorksheetFunction.CountA(Range("a1:a65536")) + 2
  12.         If myFile <> ThisWorkbook.Name Then
  13.             sql = "Select 序号,姓名,客户号,合同号,档案编号,期限,'" & Left(myFile, 6) & "' as 所在档案,部门" & _
  14.                   " From(Select *,""部门1"" as 部门 From[1部门$A3:G100]" & _
  15.                   " Union Select *,""部门2"" as 部门 From[2部门$A3:G100]" & _
  16.                   " Union Select *,""部门3"" as 部门 From[3部门$A3:G100])" & _
  17.                   " Where 姓名='" & Cells(2, 3) & "'"
  18.             cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & _
  19.                      myPath & myFile
  20.             Set rst = cnn.Execute(sql)
  21.             Range("a" & sRow).CopyFromRecordset rst
  22.             cnn.Close

  23.         End If
  24.         myFile = Dir
  25.     Wend
  26.    
  27.     Set rst = Nothing
  28.     Set cnn = Nothing
  29.     Application.ScreenUpdating = False
  30.    
  31. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-6 11:06 | 显示全部楼层
跟着赵老师学习了。



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-9 14:55 | 显示全部楼层
本帖最后由 hzhb14796 于 2011-11-10 08:59 编辑

用比较的方法,程序运行很慢,
考虑到一个档案里一个部门重名的可能性太低,可以用FIND 方法,但感觉不出那个更快,干脆都发上

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-19 17:49 | 显示全部楼层
请指正,谢谢。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1 基本正确

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-11-22 11:15 | 显示全部楼层
截至日期已到,谢谢各位参与答题,已测试各位代码,现将各位得分情况公布如下:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-11-22 11:27 | 显示全部楼层
本帖最后由 冻豆腐 于 2011-11-22 13:23 编辑

小结:

本题主要测试ADO实现多工作簿多表(超过49个)联合查询,本来有速度要求,在冻版主建议下取消了要求,只要结果正确就可以得分
为了减小难度,加了80个工作簿和“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”的条件
下面给出3个参考da'an(系统不准出现这两个字,歉),其中第一个不使用上面给出的条件,请广大会员斧正:


[code=vb]Sub Macro1() '通用,不使用条件:已知“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object, cat As Object, d As Object
    Dim SQL$, MyFile$, arr(), i&, j&, t$, s$, wk$, m&, n&
    temp = [c2]
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Set cnn = CreateObject("adodb.connection")
    Set cat = CreateObject("ADOX.Catalog")
    Set d = CreateObject("scripting.dictionary")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            wk = Replace(MyFile, ".xls", "")
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
            cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=No';Data Source=" & MyPath & MyFile
            For Each tb1 In cat.Tables
                If tb1.Type = "TABLE" Then
                    s = Replace(tb1.Name, "'", "")
                    If Right(s, 1) = "$" Then
                        m = m + 1
                        SQL = "select 序号,姓名,客户号,合同号,档案编号,期限,'" & wk & "','" & Replace(s, "$", "") & "' from [Excel 8.0;Database=" & MyPath & MyFile & "].[" & s & "a3:f65536] where 姓名='" & temp & "'"
                        d(SQL) = ""
                        If m Mod 49 = 0 Then
                            SQL = Join(d.Keys, " UNION ALL ")
                            [a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                            d.RemoveAll
                        End If
                    End If
                End If
            Next
        End If
        MyFile = Dir()
    Loop
    If d.Count > 0 Then
        SQL = Join(d.Keys, " UNION ALL ")
        [a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    End If
    Set cat = Nothing
    Set tb1 = Nothing
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub
[/code]
[code=vb]Sub Macro2() '简易,速度较快,只适用已知“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, a, arr(), i%, ii%, j%, t$, m%
    t = [c2]
    a = Array("1部门$a3:f65536", "2部门$a3:f65536", "3部门$a3:f65536")
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = MyFile
        End If
        MyFile = Dir()
    Loop
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & arr(1)
    For i = 1 To m Step 16
        SQL = ""
        For ii = i To i + 15
            If ii > m Then Exit For
            For j = 0 To 2
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 序号,姓名,客户号,合同号,档案编号,期限,'" & Replace(arr(ii), ".xls", "") & "','" & Left(a(j), 3) & "' from [Excel 8.0;Database=" & MyPath & arr(ii) & "].[" & a(j) & "] where 姓名='" & t & "'"
            Next
        Next
        [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    Next
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub
[/code]
[code=vb]Sub Macro3() '简易,速度较快,只适用已知“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, wk$, a, i%, t$, m%, n%
    t = [c2]
    a = Array("1部门", "2部门", "3部门")
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Set cnn = CreateObject("adodb.connection")
    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;Data Source=" & MyPath & MyFile
            wk = Replace(MyFile, ".xls", "")
            For i = 0 To 2
                m = m + 1
                If m > 49 Then
                    [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                    m = 1
                    SQL = ""
                End If
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 序号,姓名,客户号,合同号,档案编号,期限,'" & wk & "','" & a(i) & "' from [Excel 8.0;Database=" & MyPath & MyFile & "].[" & a(i) & "$a3:f65536] where 姓名='" & t & "'"
            Next
        End If
        MyFile = Dir()
    Loop
    If Len(SQL) Then [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub

[/code]





本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

点评

如果能做成一个加载宏,适应各种表格汇总,那就是更多人的福音了。  发表于 2011-11-22 13:28
学习了,谢谢赵老师的题目,满通用的程序,收藏。  发表于 2011-11-22 13:18

评分

参与人数 5财富 +50 鲜花 +11 技术 +2 收起 理由
小行星B612 + 2 太强大了
abc123281 + 2 优秀作品
weiyingde + 2
wcymiss + 5 经典代码,收藏
冻豆腐 + 50 非常精彩的总结

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-22 11:52 | 显示全部楼层
本帖最后由 onthetrip2008 于 2011-11-22 13:21 编辑

我还不懂什么是连接自身,请版主有空解释一下,谢谢先
------------------------
刚看了赵老师的代码,明白了,是不是data source后面是thisworkbook就视作在连接自身?
------------------------
哇哇哇,来论坛学习两年半了,终于有了神往已久的技术分,幸福啊.晚上请人喝酒去,庆祝一下今天这个好日子,呵呵......
谢谢赵老师.

点评

可能这个是马甲。。  发表于 2011-11-22 16:32
两年半,注册时间出错了?  发表于 2011-11-22 13:47
对  发表于 2011-11-22 12:39
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-6-20 15:39 , Processed in 0.092261 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表