[已解决]请老师帮忙编写一个批量提取数据的代码（2007）

dujigui

新建文件夹.rar (774.88 KB, 下载次数: 19)

2013-6-8 20:07 上传

点击文件名下载附件 把文件夹内工作簿中“费用总表”数据提取到汇总表中对应位置，工程名称为工作簿名称，请老师帮帮忙谢谢了

最佳答案

月排行榜 / 总排行榜

wp8680

2013-6-9 12:15

(, 下载次数: 28)

上传

点击文件名下载附件

跳转到最佳答案楼层

lyf7276

你看是这样的吗？ 汇总.rar (94.96 KB, 下载次数: 10)

2013-6-8 21:06 上传

点击文件名下载附件

dujigui

lyf7276 发表于 2013-6-8 21:06
你看是这样的吗？

怎么执行不了？

lyf7276

能执行呀，要不你以为那些数据我是一个个的填写上去的？

lyf7276

1、要你的四个工作簿都是打工的
2、我的代码是把你的那个汇总工作簿算最后打开的工作簿
3、那代码我没指定按钮，你要自己在汇总工作簿的工作表里执行，要么你自己指定按钮

dujigui

lyf7276 发表于 2013-6-8 21:29
1、要你的四个工作簿都是打工的
2、我的代码是把你的那个汇总工作簿算最后打开的工作簿
3、那代码我没指定 ...

要手动打开文件夹内所有工作簿，如果文件夹内有几百工作簿很麻烦，能不能再帮帮忙改一下，麻烦了！！！！

wp8680

文件.rar (834.96 KB, 下载次数: 20)

2013-6-8 21:41 上传

点击文件名下载附件

1. Sub 汇总()    '从不打开的工作簿里提取数据
   
2. 'On Error Resume Next
   
3.     Application.ScreenUpdating = False    '关闭屏幕刷新
   
4.     Dim Wb As Workbook    '定义Wb为工作簿对象型变量
   
5.     Dim MyPth As String    '定义MyPth为文本型变量
   
6.     Dim Filename As String, k As Integer
   
7.     Dim arr
   
8.     MyPth = ThisWorkbook.Path & "\石桥供电所"    '把数据源工作簿路径赋给MyPth
   
9.     Filename = Dir(MyPth, vbDirectory)
   
10.     Do While Filename <> ""
    
11.         If Filename Like "0230413*.*" Then
    
12.             Set Wb = GetObject(MyPth & Filename)    '把返回路径上的文件引用且赋值给Wb
    
13.             arr = Wb.Sheets("费用总表").Range("c4:c38")
    
14.             k = k + 1
    
15.             Wb.Close False
    
16.             Set Wb = Nothing
    
17.             With Sheets("合计")
    
18.                 .Range("a2").Offset(k, 0) = Split(Filename, ".")(0)
    
19.                 .Range("a2").Offset(k, 1).Resize(1, UBound(arr)) = Application.WorksheetFunction.Transpose(arr)
    
20.             End With
    
21.         End If
    
22.         Filename = Dir
    
23.     Loop
    
24.     Application.ScreenUpdating = True    '打开屏幕刷新
    
25. End Sub

复制代码

wp8680

上一楼代码，一键操作，但要求是汇总表必须与《石桥供电所》文件夹在同一目录下。并且，不得任意更改文件夹的名字。

如果想要更改文件夹的名字，请修改代码。
也或采用filetoopen = Application.GetOpenFilename("工作表(*.xls),*.xls")的方式方法来自已选择表格，但这样操作费力多了。

dujigui

wp8680 发表于 2013-6-8 21:43
上一楼代码，一键操作，但要求是汇总表必须与《石桥供电所》文件夹在同一目录下。并且，不得任意更改文件夹 ...

谢谢了！！我把代码改了一下 If Filename Like "0230*.*" The，下面代码在提取8个工作簿后报错
   Set Wb = GetObject(MyPth & Filename)    '把返回路径上的文件引用且赋值给Wb

wp8680

If Filename Like "023*.xls*" Then
改成这样试试，这样能正确找到，以023开头的新老版本的工作簿。