多工作簿中的数据信息汇总（难）！！！！！

kuilinq · 发表于 2011-6-3 22:59

这个程序太难了，请大家来帮帮忙！
  请帮忙修改程序，要求：
1、按“按钮1”按健时，会自动在A列将“数据”文件夹中所有的excel文件名调入(见附件表红色字体部分)
   2、同时在excel文件名的后一列开始（即B列）将相应的excel文件的内容调入（见附件表蓝色数据）
3、要是用EXCEL4宏函数：Getvalue = Application.ExecuteExcel4Macro(MyPath)
   4、本程第1点已经实现，但第2点一直实现不了，请大师帮忙修改程序来实现。

文件见附件！

zhaogang1960 · 发表于 2011-6-3 23:50

用ado如何？
Sub GetCloseXlsValue()
Dim cnn As Object, Mypath$, MyFile$, m%
Mypath = ThisWorkbook.path & "\数据\"
MyFile = Dir(Mypath & "*.xls")
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
m = 2
Do While MyFile <> ""
      Set cnn = CreateObject("adodb.connection")
      cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & Mypath & MyFile
      Cells(m, 1) = Split(MyFile, ".")(0)
      Cells(m, 2).CopyFromRecordset cnn.Execute("[数据表$a2:q4]")
      m = m + 3
      MyFile = Dir()
Loop
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

zhaogang1960 · 发表于 2011-6-3 23:52

这是附件

高难度的不同工作簿之间的数据合并.rar (56.7 KB, 下载次数: 20)

kuilinq · 发表于 2011-6-4 00:31

用ado好像是要打开所有文件才能读取内容的，这样一来，如果文件夹中有一个文件需要密码的话就会出问题；而用EXCEL4宏函数：Getvalue = Application.ExecuteExcel4Macro(MyPath)就不会存在问题,它好象可以不用打开文件就可以直接读取文件内容的.
楼主能帮忙用EXCEL4宏函数来解吗? 先感谢一下先....

kuilinq · 发表于 2011-6-4 00:34

希望楼主能帮忙用EXCEL4宏函数来修改.......小弟将十分感谢!

zhaogang1960 · 发表于 2011-6-4 01:22

原帖由 kuilinq 于 2011-6-4 00:34 发表
希望楼主能帮忙用EXCEL4宏函数来修改.......小弟将十分感谢!

不知道楼主测试过没有，不管是ado，还是数组公式，还有EXCEL4宏函数，都不能躲过密码，不信试试看：
Sub Macro1()
Dim p$, f$, m&, s$, a$, rng As Range, arr(1 To 3, 1 To 17)
Set rng = [A2:Q4]
p = ThisWorkbook.Path & "\数据\"
f = Dir(p & "*.xls")
s = "数据表"
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
m = 2
Do While f <> ""
      If f <> ThisWorkbook.Name Then
         Cells(m, 1) = Split(f, ".")(0)
         For i = 1 To 3
            For j = 1 To 17
                  a = rng(i, j).Address(0, 0)
                  arr(i, j) = getvalue(p, f, s, a)
            Next
         Next
         Cells(m, 2).Resize(3, 17) = arr
         m = m + 3
      End If
      f = Dir
Loop
Application.ScreenUpdating = True
End Sub
Private Function getvalue(pa As String, File As String, SHEET As String, REF As String)
Dim arg As String
arg = "'" & pa & "[" & File & "]" & SHEET & "'!" & Range(REF).Range("A1").Address(, , xlR1C1)
getvalue = ExecuteExcel4Macro(arg)
End Function

zhaogang1960 · 发表于 2011-6-4 01:25

附件中工作簿没有加密码，请自己加上试试

高难度的不同工作簿之间的数据合并.rar (58.19 KB, 下载次数: 29)

kuilinq · 发表于 2011-6-4 21:29

楼主讲的非常正确，是小弟学习不到位，理解错误。再次感谢zhaogang1960老师的指导！

LMY123 · 发表于 2018-8-28 17:35

Cells(m, 2).CopyFromRecordset cnn.Execute("[数据表$a2:q4]")

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

[求助] 多工作簿中的数据信息汇总（难）！！！！！

回复 3楼 zhaogang1960 的帖子

回复 3楼 zhaogang1960 的帖子

回复 7楼 zhaogang1960 的帖子