提取多个文件夹下excel中的数据问题

liushilin · 发表于 2011-6-4 17:06

哪位老师能帮忙指点一下，改改以下代码，达到我附件汇总表的要求。下面代码是提取在同一文件夹下多个excel的数据，我需要的是在不同的文件夹下提取excel的数据，且希望是按文件夹的顺序依次提取（同一文件夹下有可能需提取几个不同的excel文件，但格式都是一样的），汇总表最后一行希望能做个汇总数。谢谢！
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set cnn = CreateObject("adodb.connection")
[a7:e1000].ClearContents
h = 7
f = Dir(ThisWorkbook.Path & "\*.xls")
Do While f > " "
      If f <> ThisWorkbook.Name Then
         cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.Path & "\" & f
         Sql = "select * from[表一$e11:e11]"
         Cells(h, 3).CopyFromRecordset cnn.Execute(Sql)
         Sql = "select * from[表一$g11:g11]"
         Cells(h, 4).CopyFromRecordset cnn.Execute(Sql)
         Sql = "select * from[表一$h11:h11]"
         Cells(h, 5).CopyFromRecordset cnn.Execute(Sql)
         Cells(h, 2) = f
         h = h + 1
         cnn.Close

      End If
      f = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Admin · 发表于 2011-6-5 18:05

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。

为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

zhaogang1960 · 发表于 2011-6-10 22:02

4楼的老师帮我看看这个帖子 http://club.excelhome.net/thread-727175-1-1.html，是我之前求助的，但没人理我。请帮忙。

请测试
Private Sub CommandButton1_Click()
Dim arr()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set cnn = CreateObject("adodb.connection")
[a7:e1000].ClearContents
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
      If MyName <> "." And MyName <> ".." Then
         If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            m = m + 1
            ReDim Preserve arr(m)
            arr(m) = MyPath & MyName & "\"
         End If
      End If
      MyName = Dir
Loop
h = 7
For k = 1 To m
      f = Dir(arr(k) & "*.xls")
      Do While f > " "
         cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & arr(k) & f
         Sql = "select * from [表一$e11:e11]"
         Cells(h, 3).CopyFromRecordset cnn.Execute(Sql)
         Sql = "select * from [表一$g11:g11]"
         Cells(h, 4).CopyFromRecordset cnn.Execute(Sql)
         Sql = "select * from [表一$h11:h11]"
         Cells(h, 5).CopyFromRecordset cnn.Execute(Sql)
         Cells(h, 2) = f
         Cells(h, 1) = h - 6
         h = h + 1
         cnn.Close
         f = Dir
      Loop
Next
Cells(h, 2) = "合计"
Cells(h, 3).Resize(, 3) = "=SUM(R[-" & h - 7 & "]C:R[-1]C)"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 zhaogang1960 于 2011-6-10 22:06 编辑 ]

zhaogang1960 · 发表于 2011-6-10 22:05

附件

提取多个文件夹下excel中的数据问题.rar (288.79 KB, 下载次数: 569)

liushilin · 发表于 2011-6-12 00:27

非常感谢楼上的老师，你提供的代码已经解决了我的问题，剩下一些其它的如线框，字体，字号我想我已经能自己搞定。就是还有个小问题，为什么在这个表格保存的时候老是有警告窗口出现，是关于‘隐私问题警告’的窗口，保存一次就出现一次，不知有什么办法可以解决，我在execl选项中已经解除了一些关于隐私的项目，但还是不行。求教了！如图 QQ截图20110612001046.png

liumongshi · 发表于 2011-6-12 00:47

仅仅跟随zhao老师，继续求教：我有很多工作薄，分别在不同的文件夹下，工作薄格式完全相同，每个工作薄由八张工作表组成，现在我想提取“调查表”中的c4，h5，d3，和“审批表”里的a5，f5 单元格的内容，把这些内容分别放在新的一个工作表的a，b，c，d，e列，批量提取这些工作薄，在这个新表里形成目录的形式依次排下来，即一行表示从一个工作薄里提取的数据，要可以自由选择文件夹（包括子文件夹），自动提取文件夹下的所有excel工作薄。

zhaogang1960 · 发表于 2011-6-12 00:58

原帖由 liushilin 于 2011-6-12 00:27 发表
非常感谢楼上的老师，你提供的代码已经解决了我的问题，剩下一些其它的如线框，字体，字号我想我已经能自己搞定。就是还有个小问题，为什么在这个表格保存的时候老是有警告窗口出现，是关于‘隐私问题警告’的窗口， ...

估计你是用“新建——新建 Microsoft Excel 工作表”方法保存的工作簿
解决办法：
工具——选项——安全性——去掉“保存时从文件属性中删除个人信息”左边的勾

liushilin · 发表于 2011-6-15 18:13

谢谢老师的指点，确如老师所说，按你的方法已解决。不知老师有没有时间，帮我再改改代码，实现引用的单元格能跟随原表格数据一起变动，也就是说，引用后的单元格是链接原工作表单元格的，现在引用后是个固定的值，不能随原表格数据变动而变动.。先谢谢！

zhaogang1960 · 发表于 2011-6-15 18:17

原帖由 liushilin 于 2011-6-15 18:13 发表
谢谢老师的指点，确如老师所说，按你的方法已解决。不知老师有没有时间，帮我再改改代码，实现引用的单元格能跟随原表格数据一起变动，也就是说，引用后的单元格是链接原工作表单元格的，现在引用后是个固定的值，不 ...

你要求的应该需要公式来完成，公式我不会，建议到函数板块求助

liushilin · 发表于 2012-11-4 23:17

zhaogang1960 发表于 2011-6-10 22:05
附件

赵老师，想请教一下，假如源文件K列有数据，我想将源文件中K列有数据的最后一行的数据读到汇总表里的F列，请问要怎样修改代码。关键是源文件F列的数据不是固定的，我只读取有有效数据的最后一个单元格的数据。麻烦你抽空看看。

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

[求助] 提取多个文件夹下excel中的数据问题

〖Excel Home友情提示〗

回复 4楼 zhaogang1960 的帖子