设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 跨工作簿查询并给出路径
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1929|回复: 3

[已解决]跨工作簿查询并给出路径

[复制链接]
发表于 2016-8-19 15:58 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
如题求助，跨工作薄查询并给出路径，谢谢大侠！
跨表查图.jpg
最佳答案
月排行榜 / 总排行榜
蓝桥玄霜
2016-8-19 16:41
  1. Public Brr(), r&

  3. Sub main()
  4. Dim fp As String, Arr, i&, nm$, Myr&, j&, r1, r2, col%, d
  5. Dim Sht As Worksheet, sh As Worksheet
  6. Application.ScreenUpdating = False
  7. Set d = CreateObject("Scripting.Dictionary")
  8. fp = ThisWorkbook.Path & ""
  9. Call searfile(fp, ".xls")
  10. Sheet1.Activate
  11. [b2:b1000].ClearContents
  12. Arr = [a1].CurrentRegion
  13. For i = 2 To UBound(Arr)
  14.     d(Arr(i, 1)) = i
  15. Next
  16. k = d.keys: t = d.items
  17. For i = 1 To UBound(Brr, 2)
  18.     If Brr(2, i) <> ThisWorkbook.Name Then
  19.     With GetObject(Brr(1, i) & Brr(2, i))
  20.         For j = 0 To UBound(k)
  21.             Set r1 = .Sheets(1).[b:b].Find(k(j), , , 2)
  22.             If Not r1 Is Nothing Then
  23.                 Cells(t(j), 2) = Brr(1, i) & Brr(2, i)
  24.                 d.Remove (k(j)): k = d.keys: t = d.items: Exit For
  25.             End If
  26.         Next
  27.         .Close False
  28.     End With
  29.     End If
  30. Next
  31. Application.ScreenUpdating = True
  32. End Sub

  34. Sub searfile(fp As String, fkey As String)
  35. Dim Arr1() As String, i1 As Integer, i2 As Integer, fm
  36. If Right(fp, 1) <> "" Then fp = fp & ""
  37. If Len(fkey) < 1 Then fkey = ".xls" '文件类型省略则仅搜索.xls文件
  38. fm = Dir(fp, vbDirectory)
  39. Do While fm <> ""
  40.     If fm <> "." And fm <> ".." Then
  41.         If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
  42.             i1 = i1 + 1
  43.             ReDim Preserve Arr1(1 To i1)
  44.             Arr1(i1) = fp & fm
  45.         End If
  46.         If Right(fm, 4) = fkey Then  '如果是07版本，红字改为5
  47.             r = r + 1
  48.             ReDim Preserve Brr(1 To 2, 1 To r)
  49.             Brr(1, r) = fp
  50.             Brr(2, r) = fm
  51.         End If
  52.     End If
  53.     fm = Dir
  54. Loop
  55. For i2 = 1 To i1
  56.   Call searfile(Arr1(i2), fkey)
  57. Next
  58. End Sub

复制代码

跨表查询.zip

26.63 KB, 下载次数: 46
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2016-8-19 16:41 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Public Brr(), r&

  3. Sub main()
  4. Dim fp As String, Arr, i&, nm$, Myr&, j&, r1, r2, col%, d
  5. Dim Sht As Worksheet, sh As Worksheet
  6. Application.ScreenUpdating = False
  7. Set d = CreateObject("Scripting.Dictionary")
  8. fp = ThisWorkbook.Path & ""
  9. Call searfile(fp, ".xls")
  10. Sheet1.Activate
  11. [b2:b1000].ClearContents
  12. Arr = [a1].CurrentRegion
  13. For i = 2 To UBound(Arr)
  14.     d(Arr(i, 1)) = i
  15. Next
  16. k = d.keys: t = d.items
  17. For i = 1 To UBound(Brr, 2)
  18.     If Brr(2, i) <> ThisWorkbook.Name Then
  19.     With GetObject(Brr(1, i) & Brr(2, i))
  20.         For j = 0 To UBound(k)
  21.             Set r1 = .Sheets(1).[b:b].Find(k(j), , , 2)
  22.             If Not r1 Is Nothing Then
  23.                 Cells(t(j), 2) = Brr(1, i) & Brr(2, i)
  24.                 d.Remove (k(j)): k = d.keys: t = d.items: Exit For
  25.             End If
  26.         Next
  27.         .Close False
  28.     End With
  29.     End If
  30. Next
  31. Application.ScreenUpdating = True
  32. End Sub

  34. Sub searfile(fp As String, fkey As String)
  35. Dim Arr1() As String, i1 As Integer, i2 As Integer, fm
  36. If Right(fp, 1) <> "" Then fp = fp & ""
  37. If Len(fkey) < 1 Then fkey = ".xls" '文件类型省略则仅搜索.xls文件
  38. fm = Dir(fp, vbDirectory)
  39. Do While fm <> ""
  40.     If fm <> "." And fm <> ".." Then
  41.         If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
  42.             i1 = i1 + 1
  43.             ReDim Preserve Arr1(1 To i1)
  44.             Arr1(i1) = fp & fm
  45.         End If
  46.         If Right(fm, 4) = fkey Then  '如果是07版本，红字改为5
  47.             r = r + 1
  48.             ReDim Preserve Brr(1 To 2, 1 To r)
  49.             Brr(1, r) = fp
  50.             Brr(2, r) = fm
  51.         End If
  52.     End If
  53.     fm = Dir
  54. Loop
  55. For i2 = 1 To i1
  56.   Call searfile(Arr1(i2), fkey)
  57. Next
  58. End Sub

复制代码
回复

使用道具 举报

 楼主| 发表于 2016-8-19 16:56 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
太感谢了，谢谢版主！
好好研究一下！
回复

使用道具 举报

发表于 2016-10-27 15:03 | 显示全部楼层
马上注册 发表于 2016-8-19 16:56
太感谢了，谢谢版主！
好好研究一下！

能否再上传下文件，原文件打不开
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-7 15:30 , Processed in 0.408120 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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