Office中国论坛/Access中国论坛

标题: 已解决：指定位置提取 [打印本页]
作者: 咸中咸    时间: 2017-4-2 11:08
标题: 已解决：指定位置提取
本帖最后由 咸中咸 于 2017-4-20 19:41 编辑

各位大神、老师，excel从指定位置（比如：在D盘，但是需要提取的excel表格不在D盘）提取所需要的资料的VBA代码，请各位不吝赐教！
作者: roych    时间: 2017-4-2 12:45
没搞懂。导出VBA代码后，再导入不就好了么？
如果不想导入，只能打开文件再执行该文件的VBA代码。不过个人觉得这样很复杂。
作者: 咸中咸    时间: 2017-4-2 15:28
roych 发表于 2017-4-2 12:45
没搞懂。导出VBA代码后，再导入不就好了么？
如果不想导入，只能打开文件再执行该文件的VBA代码。不过个人 ...

可能是我没有说清楚，我是想在打开的excel表格中点击导入按钮，导入指定位置文件（该文件在其他文件夹下）中的内容
作者: roych    时间: 2017-4-3 11:35
咸中咸 发表于 2017-4-2 15:28
可能是我没有说清楚，我是想在打开的excel表格中点击导入按钮，导入指定位置文件（该文件在其他文件夹下 ...
  1. Sub test()
  2. Dim C, sPh As String
  3. Dim s As String
  4. sPh = CreateObject("Shell.Application").BrowseForFolder(0, _
  5.         "选择文件夹,程序将该文件夹保存的模块全部导入！", 0, 0).Self.Path
  6. For Each C In FileFullName(sPh)
  7.     With Application.VBE.ActiveVBProject.VBComponents
  8.         .Import C
  9.         s = s + vbCrLf + C
  10.     End With
  11. Next
  12. MsgBox "已导入：" & s
  13. End Sub
  14. '获得导入模块路径名
  15. Function FileFullName(sPath As String) As String()
  16. Dim iCt As Integer
  17. Dim TemAr() As String
  18. Dim sDir As String
  19. sDir = Dir(sPath & "" & "*.bas")
  20. While Len(sDir)
  21.     ReDim Preserve TemAr(iCt)
  22.     TemAr(iCt) = sPath & "" & sDir
  23.     iCt = iCt + 1
  24.     sDir = Dir
  25. Wend
  26. FileFullName = TemAr
  27. End Function

  29. '导出模块
  30. Sub SaveThisModule()
  31. Dim C, sPh As String
  32. Dim s As String
  33. sPh = CreateObject("Shell.Application").BrowseForFolder(0, _
  34.         "选择文件夹,程序将本工作簿的所有模块导出至该文件夹！", 0, 0).Self.Path
  35. For Each C In ThisWorkbook.VBProject.VBComponents
  36.     If C.Type = 1 Then
  37.         Application.VBE.ActiveVBProject.VBComponents(C.Name).Export (sPh & "" & C.Name & ".bas")
  38.         s = s + vbCrLf + C.Name
  39.     End If
  40. Next
  41. MsgBox "已导出：" & s
  42. End Sub
复制代码

供参考
作者: 咸中咸    时间: 2017-4-7 21:48
roych 发表于 2017-4-3 11:35
供参考

谢谢！



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3