[已解决]（加大难度）如何对若干个EXCEL文件按科目内容汇总？

shenlong2006

上午发了一个帖子（http://www.excelpx.com/thread-319786-1-2.html），当时为了举例方便，所有的示例表格数据区域的大小都是一样的，但实际工作中各个表格数据区域的大小事不一样的，所以那个帖子选为“最佳答案”的代码就无法满足要求了，下面重新编辑了各个文件，难度更大了，重新发下！

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



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



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



请问这个怎么通过VBA实现呢？
附件上传供大家研究：

汇总.rar (54.38 KB, 下载次数: 3)

2014-2-26 22:00 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-28 19:01

Sub Macro1()
Dim wb As Workbook, rng As Range
Dim x&, y&, mypath$, myfile$, s&, s2&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "正在汇总………"
ActiveSheet.UsedRange.Clear
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xls")
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name Then
        Set wb = GetObject(mypath & myfile)
        x = Range("j65536").End(xlUp).Row
        n = wb.Sheets(1).Range("l65536").End(xlUp).Row
       x2 = IIf(x = 1, 1, x + 1)
        wb.Sheets(1).Range("a5:l" & n).Copy Cells(x2, 1)
       Cells(x2, "m").Resize(n - 4, 1) = wb.Name
        wb.Close 0
    End If
    myfile = Dir
Loop
ActiveSheet.UsedRange.UnMerge
y = ActiveSheet.UsedRange.Rows.Count
[b1].Resize(y, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
ActiveSheet.UsedRange.Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
Set rng = [b1]: [a1] = 1
s2 = 1: [c1] = 1
For i = 2 To y + 1
    If Cells(i, 2) = Cells(i - 1, 2) Then
        s2 = s2 + 1
        Cells(i, 3) = s2
        Set rng = Union(rng, Cells(i, 2))
    Else
        s2 = 1: s = s + 1
        rng.Offset(, -1).Merge
        rng.Merge
        Set rng = Cells(i, 2)
        Cells(i, 3) = s2
        rng.Offset(, -1) = s + 1
    End If
Next
Cells(y + 1, 1) = ""
Cells(y + 1, 3) = ""
[1:4].Insert Shift:=xlDown
Set wb = GetObject(mypath & "北京.xls")
wb.Sheets(1).Range("A1:L4").Copy [a1]
wb.Close 0
Application.StatusBar = "已完成"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

dsmch

增加一句代码就行了


Sub Macro1()
Dim wb As Workbook, rng As Range
Dim x&, y&, mypath$, myfile$, s&, s2&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "正在汇总………"
ActiveSheet.UsedRange.Clear
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xls")
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name Then
        Set wb = GetObject(mypath & myfile)
        x = Range("j65536").End(xlUp).Row
        n = wb.Sheets(1).Range("l65536").End(xlUp).Row
       wb.Sheets(1).Range("a5:l" & n).Copy Cells(IIf(x = 1, 1, x + 1), 1)
        wb.Close 0
    End If
    myfile = Dir
Loop
ActiveSheet.UsedRange.UnMerge
y = ActiveSheet.UsedRange.Rows.Count
[b1].Resize(y, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
ActiveSheet.UsedRange.Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
Set rng = [b1]: [a1] = 1
s2 = 1: [c1] = 1
For i = 2 To y + 1
    If Cells(i, 2) = Cells(i - 1, 2) Then
        s2 = s2 + 1
        Cells(i, 3) = s2
        Set rng = Union(rng, Cells(i, 2))
    Else
        s2 = 1: s = s + 1
        rng.Offset(, -1).Merge
        rng.Merge
        Set rng = Cells(i, 2)
        Cells(i, 3) = s2
        rng.Offset(, -1) = s + 1
    End If
Next
Cells(y + 1, 1) = ""
Cells(y + 1, 3) = ""
[1:4].Insert Shift:=xlDown
Set wb = GetObject(mypath & "北京.xls")
wb.Sheets(1).Range("A1:L4").Copy [a1]
wb.Close 0
Application.StatusBar = "已完成"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

dsmch

………………

shenlong2006

dsmch 发表于 2014-2-26 22:00
增加一句代码就行了

老师，我若是想在后面一列填上各个文件的名称，请问该怎么弄呢？

dsmch

Sub Macro1()
Dim wb As Workbook, rng As Range
Dim x&, y&, mypath$, myfile$, s&, s2&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "正在汇总………"
ActiveSheet.UsedRange.Clear
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xls")
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name Then
        Set wb = GetObject(mypath & myfile)
        x = Range("j65536").End(xlUp).Row
        n = wb.Sheets(1).Range("l65536").End(xlUp).Row
       x2 = IIf(x = 1, 1, x + 1)
        wb.Sheets(1).Range("a5:l" & n).Copy Cells(x2, 1)
       Cells(x2, "m").Resize(n - 4, 1) = wb.Name
        wb.Close 0
    End If
    myfile = Dir
Loop
ActiveSheet.UsedRange.UnMerge
y = ActiveSheet.UsedRange.Rows.Count
[b1].Resize(y, 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
ActiveSheet.UsedRange.Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
Set rng = [b1]: [a1] = 1
s2 = 1: [c1] = 1
For i = 2 To y + 1
    If Cells(i, 2) = Cells(i - 1, 2) Then
        s2 = s2 + 1
        Cells(i, 3) = s2
        Set rng = Union(rng, Cells(i, 2))
    Else
        s2 = 1: s = s + 1
        rng.Offset(, -1).Merge
        rng.Merge
        Set rng = Cells(i, 2)
        Cells(i, 3) = s2
        rng.Offset(, -1) = s + 1
    End If
Next
Cells(y + 1, 1) = ""
Cells(y + 1, 3) = ""
[1:4].Insert Shift:=xlDown
Set wb = GetObject(mypath & "北京.xls")
wb.Sheets(1).Range("A1:L4").Copy [a1]
wb.Close 0
Application.StatusBar = "已完成"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub