[已解决]求助大家，关于遍历提取

古典文学

如附近中例子文件夹，原始数据文件夹内有若干个工作薄，每个工作薄里面格式相同。
现想实现遍历每一个工作薄，然后将成果工作表里面的a1：c10，内容复制出来。粘贴到汇总工作薄里面，从第二列开始粘贴，而第一列返回对应的工作薄的名字。下一个工作薄的内容在汇总中顺延。
例子中复制了两个工作薄的内容（分别是1-西沟，2-后峪），其他类同。
感谢老师

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-1 10:17

07以上版本，getobject可能无法使用

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, s&
   
3. ReDim brr(1 To 60000, 1 To 4)
   
4. mypath = ThisWorkbook.Path & "\原始数据"
   
5. wj = Dir(mypath & "*.xls*")
   
6. Application.ScreenUpdating = False
   
7. Do While wj <> ""
   
8.     With Workbooks.Open(mypath & wj)
   
9.         arr = .Sheets("成果").[a1:c10]
   
10.         For i = 1 To UBound(arr)
    
11.             s = s + 1
    
12.             brr(s, 1) = .Name
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 brr(s, j + 1) = arr(i, j)
    
15.             Next
    
16.         Next
    
17.         .Close 0
    
18.     End With
    
19.     wj = Dir
    
20. Loop
    
21. Range("a1").Resize(s, UBound(brr, 2)) = brr
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

跳转到最佳答案楼层

古典文学

自己顶一下

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, s&
   
3. ReDim brr(1 To 60000, 1 To 4)
   
4. mypath = ThisWorkbook.Path & "\原始数据"
   
5. wj = Dir(mypath & "*.xls*")
   
6. Application.ScreenUpdating = False
   
7. Do While wj <> ""
   
8.     With GetObject(mypath & wj)
   
9.         arr = .Sheets("成果").[a1:c10]
   
10.         For i = 1 To UBound(arr)
    
11.             s = s + 1
    
12.             brr(s, 1) = .Name
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 brr(s, j + 1) = arr(i, j)
    
15.             Next
    
16.         Next
    
17.         .Close 0
    
18.     End With
    
19.     wj = Dir
    
20. Loop
    
21. Range("a1").Resize(s, UBound(brr, 2)) = brr
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

古典文学

dsmch 发表于 2016-4-1 09:52

多谢老师
代码我复制了没能实现，显示的是应用程序定义或对象定义错误。
不知道是不是我操作的问题
麻烦您再帮看看 再次感谢

dsmch

07以上版本，getobject可能无法使用

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, s&
   
3. ReDim brr(1 To 60000, 1 To 4)
   
4. mypath = ThisWorkbook.Path & "\原始数据"
   
5. wj = Dir(mypath & "*.xls*")
   
6. Application.ScreenUpdating = False
   
7. Do While wj <> ""
   
8.     With Workbooks.Open(mypath & wj)
   
9.         arr = .Sheets("成果").[a1:c10]
   
10.         For i = 1 To UBound(arr)
    
11.             s = s + 1
    
12.             brr(s, 1) = .Name
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 brr(s, j + 1) = arr(i, j)
    
15.             Next
    
16.         Next
    
17.         .Close 0
    
18.     End With
    
19.     wj = Dir
    
20. Loop
    
21. Range("a1").Resize(s, UBound(brr, 2)) = brr
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

古典文学

dsmch 发表于 2016-4-1 10:17
07以上版本，getobject可能无法使用

实现了  感谢老师  祝您顺利