[已解决]如何用VBA语句把同一文件夹下的工作簿汇总到一个工作簿里

chensir

如何用VBA语句把同一文件夹下除 "汇总表" 外的工作簿汇总到"汇总表"这个工作簿里，谢谢

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-14 16:34

1. Sub Macro1()
   
2. Dim wb As Workbook, mypath$, wj$
   
3. Dim rng As Range, c As Range, s&
   
4. Application.ScreenUpdating = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls")
   
7. ActiveSheet.UsedRange.Clear
   
8. s = 1
   
9. Do While wj <> ""
   
10.     If wj <> ThisWorkbook.Name Then
    
11.         Set wb = GetObject(mypath & wj)
    
12.         Set rng = wb.Sheets(1).Range("a1").CurrentRegion
    
13.         If s = 1 Then Set c = rng Else Set c = rng.Offset(1, 0)
    
14.         c.Copy Cells(s, 1)
    
15.         s = s + c.Rows.Count
    
16.         wb.Close 0
    
17.     End If
    
18.     wj = Dir
    
19. Loop
    
20. Application.ScreenUpdating = True
    
21. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim wb As Workbook, mypath$, wj$
   
3. Dim rng As Range, c As Range, s&
   
4. Application.ScreenUpdating = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls")
   
7. ActiveSheet.UsedRange.Clear
   
8. s = 1
   
9. Do While wj <> ""
   
10.     If wj <> ThisWorkbook.Name Then
    
11.         Set wb = GetObject(mypath & wj)
    
12.         Set rng = wb.Sheets(1).Range("a1").CurrentRegion
    
13.         If s = 1 Then Set c = rng Else Set c = rng.Offset(1, 0)
    
14.         c.Copy Cells(s, 1)
    
15.         s = s + c.Rows.Count
    
16.         wb.Close 0
    
17.     End If
    
18.     wj = Dir
    
19. Loop
    
20. Application.ScreenUpdating = True
    
21. End Sub

复制代码

那么的帅

代码 在 汇总表 文件 里

320901-VBA-汇总不同工作簿的工作表.zip (113.13 KB, 下载次数: 26)

2014-3-14 16:35 上传

点击文件名下载附件

dsmch

………………

风林火山

1. Sub test()
   
2.     Dim str$, str_Path$, arr
   
3.     str_Path = ThisWorkbook.Path & ""
   
4.     str = Dir(str_Path & "*.xls")
   
5.     Range("a2:f10000").ClearContents
   
6.     Application.ScreenUpdating = False
   
7.     On Error Resume Next
   
8.     Do While str <> ""
   
9.         If InStr(str, "汇总表") = 0 Then
   
10.             Workbooks.Open str_Path & str
    
11.             arr = Range("a2:f" & Cells(Rows.Count, 1).End(3).Row)
    
12.             ActiveWorkbook.Close 0
    
13.         End If
    
14.         Sheets("汇总表").Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(UBound(arr), UBound(arr, 2)) = arr
    
15.         str = Dir
    
16.         Erase arr
    
17.     Loop
    
18.     Application.ScreenUpdating = False
    
19. End Sub

复制代码

chensir

多谢各位，都可实现，按先后顺序给最佳了