ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 52040|回复: 99

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-10-26 22:56 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:工作表和工作簿
本帖最后由 zhaogang1960 于 2011-11-22 14:47 编辑

1.答题前请先阅读最新规则:正式竞赛区运行规则说明
2.可跟贴直接发答案、上传答案附件

题目说明及答题要求:
本题目为实际应用题,不需要深奥的理论,题目如下:
有80个格式相同的工作簿,每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门,每个工作表都有很多记录,要求输入姓名,快速查询出该姓名所有记录及所在工作簿和工作表名,方法不限,如果使用ADO查询,不能连接自身,复制数据次数不超过5次,数组法和ADO法不得混用,答案正确且方法符合要求者可得分,用时少者可以另行加分。

评分:
1.总分2分。
2.精彩答案另加分。

截至日期:2011-11-21前
附件:

效果演示:


该贴已经同步到 zhaogang1960的微博

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-10-28 15:53 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
速度不行。。。
先回复一个,传统的数组法。

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2011-10-28 17:26 | 显示全部楼层
更新个SQL版本的。
不知道跟赵老师的答案是否相符哈。。速度还是可以的。

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-10-28 22:18 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 ExcelHome 于 2012-10-6 17:11 编辑

不知对不对,请老师指点:


本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-10-31 15:00 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 xmyjk 于 2011-11-21 22:08 编辑

分析题目已知条件:(1)工作表数量已知:80个;
(2)格式已知:每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门

经上分析,不需在用ADO植入连接或者打开表获取表名,直接用ADO查询获取数据且不打开表可加快效率,不过没记错的话,ADO+SQL中,UNION ALL最多支持连接49个表。那就没16个工作薄做一次ADO连接吧。
程序如下:
  1. Option Explicit
  2. Sub 按钮2_Click()
  3.     Dim d, j&, cn, T As Double, sql$, MyPath$, MyFiles$, TWb$, bm$, m&, nm&

  4.     Application.ScreenUpdating = False
  5.     T = Timer
  6.     Range([A4], [H65536].End(3).Offset(1)).Clear
  7.     Set d = CreateObject("scripting.dictionary")
  8.     Set cn = CreateObject("ADODB.Connection")
  9.     TWb = ThisWorkbook.Name
  10.     MyPath = ThisWorkbook.Path
  11.     MyFiles = Dir(MyPath & "\*.xls")

  12.     Do While MyFiles <> ""
  13.         If TWb <> MyFiles Then
  14.             m = m + 1
  15.             bm = Replace(MyFiles, ".xls", "")
  16.             For j = 1 To 3
  17.                 sql = "Select """ & bm & """ ,""" & j & "部门"" ,* From [excel 8.0;HDR=NO;DATABASE=" & MyPath & "" & MyFiles & "].[" & j & "部门$]"
  18.                 d(sql) = ""
  19.             Next
  20.             If m Mod 16 = 0 Then
  21.                 sql = Join(d.Keys, " UNION ALL ")
  22.                 sql = "SELECT F1,F2,F3,F4,F5,F6,EXPR1000,EXPR1001 from (" & sql & ") WHERE F2 = '" & Cells(2, 3).Value & "'"
  23.                 sql = Replace(sql, "[excel 8.0;HDR=NO;DATABASE=" & MyPath & "" & MyFiles & "].", "")
  24.                 cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & MyPath & "" & MyFiles
  25.                 [a65536].End(3).Offset(1).CopyFromRecordset cn.Execute(sql)
  26.                 cn.Close
  27.                 d.RemoveAll
  28.                 nm = nm + 1
  29.             End If
  30.         End If
  31.         MyFiles = Dir
  32.     Loop

  33.     Set cn = Nothing: Set d = Nothing
  34.     Application.ScreenUpdating = True
  35.     MsgBox "取数" & nm & "次;耗时" & Timer - T & "秒"
  36. End Sub
复制代码

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-10-31 21:55 | 显示全部楼层
算法不是太难。

代码如下:

Option Explicit
Const QSH As Integer = 3        '定义每个工作表数据的起始行
Const SHT_COUNT As Integer = 3      '定义每个档案中工作表的个数
Rem ++++++++++++++++++++定义档案类型+++++++++++++++++++++++
Private Type type_da
    xuHao As Integer
    xingMing As String
    keHuHao As String
    heTongHao As String
    danAnBianHao As String
    qiXian As Date
    suoZaiDangan As String
    buMen As String
End Type
Dim DA(1500) As type_da                 '定义档案类型数组
Dim ct_rec As Integer                       '定义记录个数
Dim find_name As String                   '定义要查找人员的名字

Private Sub CommandButton1_Click()
Rem         '获取当前工作表下的所有文件并判断

Dim me_Path As String                    '定义当前文件所在的目录
Dim FSO                                           '定义文件对象
Dim files                                            '定义文件集合
Dim xfile                                           '定义文件

find_name = ThisWorkbook.Sheets(1).Cells(2, 3).Value
If find_name = "" Then
    MsgBox "请输入要查找人员的姓名", vbOKOnly + vbExclamation, "注意"
    Exit Sub
End If
Application.ScreenUpdating = False
ct_rec = 0                  '必须重设为0,否则连续查找时会出错
Set FSO = CreateObject("Scripting.FileSystemObject")
me_Path = ThisWorkbook.Path
For Each xfile In FSO.GetFolder(me_Path).files
    If xfile.Name Like "###号档案.xls" Then READ_DANGAN (me_Path & "\" & xfile.Name)        '当文件名符合档案文件名时,从其中读取数据
Next

PASTE_DATA
Application.ScreenUpdating = True
MsgBox "已经完成了档案的搜索" & vbCrLf & "共找到 " & ct_rec & " 条符合要求的档案 。", vbOKOnly + vbInformation, "注意"

End Sub

Private Sub READ_DANGAN(ByVal wjm As String)
Rem                 打开文件并读取其中符合条件的数写入到数组中
Rem                 关闭屏幕刷新,提高运行速度

Dim xbook As Workbook
Dim xsheet As Worksheet

Dim rnga As Range
Dim js_a As Integer
Dim js_b As Integer
Dim js_c As Integer

Set xbook = Workbooks.Open(wjm)
For js_a = 1 To SHT_COUNT
    Set xsheet = xbook.Sheets(js_a)
    With xsheet
        .Activate
        .Cells(QSH, 1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown)).Select
        Set rnga = Selection
        js_b = QSH + rnga.Rows.Count
        js_c = QSH + 1
        
        Do While js_c < js_b
            If .Cells(js_c, 2).Value = find_name Then
                DA(ct_rec).xuHao = .Cells(js_c, 1).Value
                DA(ct_rec).xingMing = find_name               '使用查询的名字,更快捷一些
                DA(ct_rec).keHuHao = .Cells(js_c, 3).Value
                DA(ct_rec).heTongHao = .Cells(js_c, 4).Value
                DA(ct_rec).danAnBianHao = .Cells(js_c, 5).Value
                DA(ct_rec).qiXian = .Cells(js_c, 6).Value
                DA(ct_rec).suoZaiDangan = Left(xbook.Name, InStr(UCase(xbook.Name), ".XLS") - 1)        '获取所在工作表中的名字中扩展名以外的部分
                DA(ct_rec).buMen = xsheet.Name
                ct_rec = ct_rec + 1
            End If
            js_c = js_c + 1
        Loop
    End With
Next
xbook.Close False
End Sub
Private Sub PASTE_DATA()
Rem    将数据粘贴到对应本工作表中对应的区域
Dim js_a As Integer
Dim js_b As Integer
   
With ThisWorkbook.ActiveSheet
    .Rows("4:1500").Delete
    .Range("C:D").NumberFormatLocal = "@"                       '设定文字格式,避免科学计数
    .Range("F:F").NumberFormatLocal = "yyyy-m-d"
    js_a = ct_rec + 4 - 1
    For js_b = 4 To js_a
        .Cells(js_b, 1).Value = DA(js_b - 4).xuHao
        .Cells(js_b, 2).Value = find_name
        .Cells(js_b, 3).Value = DA(js_b - 4).keHuHao
        .Cells(js_b, 4).Value = DA(js_b - 4).heTongHao
        .Cells(js_b, 5).Value = DA(js_b - 4).danAnBianHao
        .Cells(js_b, 6).Value = DA(js_b - 4).qiXian
        .Cells(js_b, 7).Value = DA(js_b - 4).suoZaiDangan
        .Cells(js_b, 8).Value = DA(js_b - 4).buMen
    Next
End With
   
End Sub


本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-1 13:10 | 显示全部楼层
本帖最后由 huangwei0king 于 2011-11-1 13:56 编辑

  1. Sub 记录查询()
  2.     Dim cent, s, i, j, p, n, m, pp
  3.     Dim pt As String
  4.     Dim t, fnanme
  5.     Dim arr
  6.     Dim brr() As String
  7.     Application.ScreenUpdating = False
  8.     On Error Resume Next
  9.     pt = ThisWorkbook.Path
  10.     Set cent = CreateObject("Scripting.FileSystemObject")
  11.     Set s = cent.GetFolder(pt)
  12.     t = ThisWorkbook.Sheets(1).Range("c2")
  13.     For Each i In s.Files
  14.         If i <> ThisWorkbook.FullName Then
  15.             Workbooks.Open Filename:=i
  16.             fname = Left(Workbooks(2).Name, 6)
  17.             For j = 1 To 3
  18.                 p = Workbooks(2).Sheets(j).Range("a65536").End(xlUp).Row
  19.                 arr = Workbooks(2).Sheets(j).Range("a4:f" & p)
  20.                 For n = 1 To UBound(arr)
  21.                     If arr(n, 2) = t Then
  22.                         m = m + 1
  23.                         ReDim Preserve brr(1 To 8, 1 To m)
  24.                         brr(1, m) = arr(n, 1)
  25.                         brr(2, m) = arr(n, 2)
  26.                         brr(3, m) = arr(n, 3)
  27.                         brr(4, m) = arr(n, 4)
  28.                         brr(5, m) = arr(n, 5)
  29.                         brr(6, m) = arr(n, 6)
  30.                         brr(7, m) = fname
  31.                         brr(8, m) = Workbooks(2).Sheets(j).Name
  32.                     End If
  33.                 Next
  34.                 Erase arr
  35.             Next
  36.             Workbooks(2).Close SaveChanges:=False
  37.         End If
  38.     Next
  39.     pp = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
  40.     If pp > 3 Then
  41.         ThisWorkbook.Sheets(1).Range("a4:h" & pp).ClearContents
  42.     End If
  43.     ThisWorkbook.Sheets(1).Range("a4").Resize(UBound(brr, 2), 8) = Application.Transpose(brr)
  44.     Erase brr
  45.     Application.ScreenUpdating = True
  46. End Sub
  47. 附件传不上来,太大了,400多K!
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-2 12:06 | 显示全部楼层
虽然做出来来了,但代码笨拙,很多内在的原理还没搞明白

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-2 20:45 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 chunlin1wang 于 2011-11-3 14:56 编辑

  1. Sub myzc()
  2.     Dim MyFile As Object
  3.     Dim MyApp As New Application
  4.     Dim Sh As Worksheet, rng As Range
  5.     Dim Temp As String, Mydir As String, Mymc As String
  6.     Dim i As Integer, n As Integer
  7.     n = 4
  8.         MyApp.Visible = False
  9.         Range("A4:H65536").ClearContents
  10.         Mydir = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
  11.         Do While Mydir <> ""
  12.             If Mydir <> "&para;à&sup1;¤×÷&sup2;&frac34;&para;à&sup1;¤×÷±í&Ecirc;&yacute;&frac34;&Yacute;&sup2;é&Ntilde;&macr;.xls" Then
  13.                 Set MyFile = CreateObject("Scripting.FileSystemObject")
  14.                 Mymc = MyFile.GetBaseName(Mydir)
  15.                 Temp = ThisWorkbook.Path & "" & Mydir
  16.                 For i = 1 To 3
  17.                     Set Sh = MyApp.Workbooks.Open(Temp).Sheets(i & "&sup2;&iquest;&Atilde;&Aring;")
  18.                         For k = 4 To Sh.Range("A65536").End(xlUp).Row
  19.                             If Sh.Range("B" & k) = Range("C2").Value Then
  20.                                 For l = 1 To 6
  21.                                     Cells(n, l) = Sh.Cells(k, l)
  22.                                 Next l
  23.                                 Cells(n, 7) = Mymc
  24.                                 Cells(n, 8) = i & "&sup2;&iquest;&Atilde;&Aring;"
  25.                                 n = n + 1
  26.                             End If
  27.                         Next k
  28.                 Next i
  29.                 MyApp.Quit
  30.                 Set MyFile = Nothing
  31.                 Set Sh = Nothing
  32.             End If
  33.             Mydir = Dir
  34.         Loop
  35.         Set MyApp = Nothing
  36.   End Sub

复制代码

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-3 10:53 | 显示全部楼层
  1.   Private Sub CommandButton1_Click()
  2. Dim myPath$, myFile$, AK As Workbook, k%, i As Integer, ii%
  3. Dim arr()
  4.     Application.ScreenUpdating = False        '冻结屏幕,以防屏幕抖动
  5.     myPath = ThisWorkbook.Path & ""          '把文件路径定义给变量
  6.     ThisWorkbook.Sheets(1).Range("a4").CurrentRegion.Offset(2, 0).Clear
  7.     myFile = Dir(myPath & "*.xls") '依次找寻指定路径中的*.xls文件
  8.     Do While myFile <> ""                     '当指定路径中有文件时进行循环
  9.     If myFile <> ThisWorkbook.Name Then
  10.     Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件
  11.         For i = 1 To AK.Sheets.Count
  12.           For ii = 4 To AK.Sheets(i).Range("b65536").End(xlUp).Row
  13.         With ThisWorkbook.Sheets(1)
  14.             If AK.Sheets(i).Cells(ii, 2).Value = .Range("c2").Value Then
  15.             k = k + 1
  16.                ReDim Preserve arr(1 To 8, 1 To k)
  17.                arr(1, k) = AK.Sheets(i).Cells(ii, 1)
  18.                arr(2, k) = AK.Sheets(i).Cells(ii, 2)
  19.                arr(3, k) = AK.Sheets(i).Cells(ii, 3)
  20.                arr(4, k) = AK.Sheets(i).Cells(ii, 4)
  21.                arr(5, k) = AK.Sheets(i).Cells(ii, 5)
  22.                arr(6, k) = AK.Sheets(i).Cells(ii, 6)
  23.                arr(7, k) = Left(AK.Name, Len(AK.Name) - 4)
  24.                arr(8, k) = AK.Sheets(i).Name
  25.             End If
  26.             End With
  27.          Next ii
  28.     Next i
  29.     AK.Close False
  30.     End If
  31.     myFile = Dir                                   '找寻下一个*.xls文件
  32.     Loop
  33.     Range("a4:H" & UBound(arr, 2) + 3) = Application.Transpose(arr)
  34.     Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用
  35. End Sub

复制代码

本帖子中包含更多资源

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

x

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 15:17 , Processed in 0.047693 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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