[已解决]请问如何对若干个EXCEL文件按科目内容汇总！

shenlong2006

有若干个地区的报表文件（如下图）



每个报表都是按科目分类统计的（格式如下图）



我现在想把所有的地区按科目进行汇总，科目相同的汇在一起，比如我将北京、天津汇在一起效果如下：



请问这个怎么通过VBA实现呢？
附件上传供大家研究：
汇总.rar (53.6 KB, 下载次数: 16)

2014-2-26 08:06 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-26 14:09

1. Sub Macro1()
   
2. Dim wb As Workbook, rng As Range
   
3. Dim x&, y&, mypath$, myfile$, s&, s2&
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Application.StatusBar = "正在汇总………"
   
7. ActiveSheet.UsedRange.Clear
   
8. mypath = ThisWorkbook.Path & ""
   
9. myfile = Dir(mypath & "*.xls")
   
10. Do While myfile <> ""
    
11.     If myfile <> ThisWorkbook.Name Then
    
12.         Set wb = GetObject(mypath & myfile)
    
13.         x = Range("j65536").End(xlUp).Row
    
14.         wb.Sheets(1).[a5:l32].Copy Cells(IIf(x = 1, 1, x + 1), 1)
    
15.         wb.Close 0
    
16.     End If
    
17.     myfile = Dir
    
18. Loop
    
19. ActiveSheet.UsedRange.UnMerge
    
20. y = ActiveSheet.UsedRange.Rows.Count
    
21. [b1].Resize(y, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    
22. ActiveSheet.UsedRange.Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
    
23. Set rng = [b1]: [a1] = 1
    
24. s2 = 1: [c1] = 1
    
25. For i = 2 To y + 1
    
26.     If Cells(i, 2) = Cells(i - 1, 2) Then
    
27.         s2 = s2 + 1
    
28.         Cells(i, 3) = s2
    
29.         Set rng = Union(rng, Cells(i, 2))
    
30.     Else
    
31.         s2 = 1: s = s + 1
    
32.         rng.Offset(, -1).Merge
    
33.         rng.Merge
    
34.         Set rng = Cells(i, 2)
    
35.         Cells(i, 3) = s2
    
36.         rng.Offset(, -1) = s + 1
    
37.     End If
    
38. Next
    
39. Cells(y + 1, 1) = ""
    
40. Cells(y + 1, 3) = ""
    
41. [1:4].Insert Shift:=xlDown
    
42. Set wb = GetObject(mypath & "北京.xls")
    
43. wb.Sheets(1).Range("A1:L4").Copy [a1]
    
44. wb.Close 0
    
45. Application.StatusBar = "已完成"
    
46. Application.DisplayAlerts = True
    
47. Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim wb As Workbook, rng As Range
   
3. Dim x&, y&, mypath$, myfile$, s&, s2&
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Application.StatusBar = "正在汇总………"
   
7. ActiveSheet.UsedRange.Clear
   
8. mypath = ThisWorkbook.Path & ""
   
9. myfile = Dir(mypath & "*.xls")
   
10. Do While myfile <> ""
    
11.     If myfile <> ThisWorkbook.Name Then
    
12.         Set wb = GetObject(mypath & myfile)
    
13.         x = Range("j65536").End(xlUp).Row
    
14.         wb.Sheets(1).[a5:l32].Copy Cells(IIf(x = 1, 1, x + 1), 1)
    
15.         wb.Close 0
    
16.     End If
    
17.     myfile = Dir
    
18. Loop
    
19. ActiveSheet.UsedRange.UnMerge
    
20. y = ActiveSheet.UsedRange.Rows.Count
    
21. [b1].Resize(y, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    
22. ActiveSheet.UsedRange.Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
    
23. Set rng = [b1]: [a1] = 1
    
24. s2 = 1: [c1] = 1
    
25. For i = 2 To y + 1
    
26.     If Cells(i, 2) = Cells(i - 1, 2) Then
    
27.         s2 = s2 + 1
    
28.         Cells(i, 3) = s2
    
29.         Set rng = Union(rng, Cells(i, 2))
    
30.     Else
    
31.         s2 = 1: s = s + 1
    
32.         rng.Offset(, -1).Merge
    
33.         rng.Merge
    
34.         Set rng = Cells(i, 2)
    
35.         Cells(i, 3) = s2
    
36.         rng.Offset(, -1) = s + 1
    
37.     End If
    
38. Next
    
39. Cells(y + 1, 1) = ""
    
40. Cells(y + 1, 3) = ""
    
41. [1:4].Insert Shift:=xlDown
    
42. Set wb = GetObject(mypath & "北京.xls")
    
43. wb.Sheets(1).Range("A1:L4").Copy [a1]
    
44. wb.Close 0
    
45. Application.StatusBar = "已完成"
    
46. Application.DisplayAlerts = True
    
47. Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

dsmch

打开文件夹中汇总工作簿，点击按钮

shenlong2006

dsmch 发表于 2014-2-26 14:12
打开文件夹中汇总工作簿，点击按钮

厉害啊，creatobject（）和getobject（）从来就不会用，还得努力学习啊！

北极牛

学无止境。