[已解决]如何批量复提取（复制）各工作薄数据？

dfshm

附件 批量提取工作薄数据.rar (59.29 KB, 下载次数: 15)

2014-3-28 09:05 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-28 12:47

1. Sub Macro1()
   
2. Dim wb As Workbook, mypath$, wj$, n&, rng As Range
   
3. mypath = ThisWorkbook.Path & "\数据"
   
4. Application.ScreenUpdating = False
   
5. Sheet2.UsedRange.Clear
   
6. wj = Dir(mypath & "*.xls")
   
7. n = 1
   
8. Do While wj <> ""
   
9.     Set wb = GetObject(mypath & wj)
   
10.     Set rng = wb.Sheets(1).Range("a1").CurrentRegion
    
11.     rng.Copy Sheet2.Cells(1, n)
    
12.     n = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
13.    Sheet2.Cells(1, n - 1).Resize(rng.Rows.Count, 1).Interior.ColorIndex = 6
    
14.     wb.Close 0
    
15. wj = Dir
    
16. Loop
    
17. Sheet2.Activate
    
18. Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim wb As Workbook, mypath$, wj$, n&, rng As Range
   
3. mypath = ThisWorkbook.Path & "\数据"
   
4. Application.ScreenUpdating = False
   
5. Sheet2.UsedRange.Clear
   
6. wj = Dir(mypath & "*.xls")
   
7. n = 1
   
8. Do While wj <> ""
   
9.     Set wb = GetObject(mypath & wj)
   
10.     Set rng = wb.Sheets(1).Range("a1").CurrentRegion
    
11.     rng.Copy Sheet2.Cells(1, n)
    
12.     n = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
13.    Sheet2.Cells(1, n - 1).Resize(rng.Rows.Count, 1).Interior.ColorIndex = 6
    
14.     wb.Close 0
    
15. wj = Dir
    
16. Loop
    
17. Sheet2.Activate
    
18. Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

dsmch

………………

dfshm

dsmch 发表于 2014-3-28 12:48
………………

谢谢老师。