[求助]又一种多工作簿汇总.rar

河山

     现在我又想到了又一种新要求,数学科汇总工作簿名为"数学",在"数学科"数据源文件夹外,文件夹里有多个学校的数学科成绩,且每个学校的班级数及人数都不一样,在汇总表设置一个按扭,点击按扭所有数据都汇总到"数学"工作簿里,且按由学校1到学校3依次连续,如附件所示,也许可以从前面的汇总代码改改就可以,但我实在不懂VBA,从今天zhaogang1960老师的帮忙以后,我才真正认识到VBA的强大,对我们工作中帮助实在太大,在这里还想请在百忙中的zhaogang1960老师再次帮忙一下,小弟再次谢谢你了

S9l23P9m.rar (24.1 KB, 下载次数: 493)

2008-9-29 23:34 上传

点击文件名下载附件
[求助]又一种多工作簿汇总.rar

zhaogang1960

8HJ19vC6.rar (30.5 KB, 下载次数: 1494)

2008-9-30 00:46 上传

点击文件名下载附件
[求助]又一种多工作簿汇总.rar

试试看

河山

谢谢zhaogang1960兄弟,做得很好,前两天出去玩了,不得给你回复,对不起了.谢谢!!!!

barlz

这个VBA如何解读，能否进行注释下，使我们能够灵活运用。

Sub 汇总()
    Dim myPath$, myFile$, sht As Worksheet
    Dim arr, lr As Long, lr2 As Long
    myPath = ThisWorkbook.Path & "\数学\"
    myFile = Dir(myPath & "\*.xls")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Range("e8:h65536").ClearContents
    With ThisWorkbook.Sheets("Sheet1")
        Do While myFile <> ""
        Workbooks.Open myPath & myFile
        For Each sht In Sheets
            lr = sht.Range("d65536").End(xlUp).Row
            lr2 = .Range("e65536").End(xlUp).Row + 1
            arr = sht.Range("d9:g" & lr).Value
            .Range("e" & lr2).Resize(UBound(arr, 1), 4) = arr
        Next
        ActiveWorkbook.Close
        myFile = Dir
        Loop
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

zhaogang1960

请参考：

Sub 汇总()
    Dim myPath$, myFile$, sht As Worksheet
    Dim arr, lr As Long, lr2 As Long             '声明变量
    myPath = ThisWorkbook.Path & "\数学\"         '给路径变量赋值
    myFile = Dir(myPath & "\*.xls")               '用dir函数提取一个文件名
    Application.ScreenUpdating = False           '关闭屏幕刷新
    Application.DisplayAlerts = False            '禁用所有事件
    Range("e8:h65536").ClearContents             '清除数据区内容
    With ThisWorkbook.Sheets("Sheet1")            'with语句，下列最左边只有“.”的语句有共同的对象ThisWorkbook.Sheets("Sheet1")
        Do While myFile <> ""                     '当文件名不为空循环
        Workbooks.Open myPath & myFile            '打开“数学”目录中的一个文件
        For Each sht In Sheets                    '对这个文件的每个工作表(这里假设每个文件的工作表数不定)
            lr = sht.Range("d65536").End(xlUp).Row          '工作表d列最后一个数据单元格行号
            lr2 = .Range("e65536").End(xlUp).Row + 1        '主工作表e列最后一个空单元格
            arr = sht.Range("d9:g" & lr).Value              '将打开工作簿工作表的数据区域读入数组arr
            .Range("e" & lr2).Resize(UBound(arr, 1), 4) = arr       '数组arr写入主工作表相应数据区域
        Next                                     '继续循环打开文件的每个工作表，这里不会循环了，因为每个文件只有一张表
        ActiveWorkbook.Close                     '关闭打开的工作簿
        myFile = Dir                             '再用dir函数提取一个文件名
        Loop                                      '继续循环，重复上述过程
    End With
    Application.DisplayAlerts = True      '      启用所有事件
    Application.ScreenUpdating = True            '打开屏幕刷新
End Sub  

deluxth

好贴,留个记号。有空回过头来慢慢学习

name004

今天才看到此贴，真是悔之晚矣1,zhaogang1960 技术较好。

chnghoat

条件不变，其他功能不变，上贴中的文件夹要实现自主选择，改怎样设计呢？也就是说设计一个宏汇总某一文件夹（文件夹可任选）下多工作簿（工作簿数不固定，每工作簿的工作表数不固定，各表格式相同，记录数不同）

dfbhy44702

请教zhaogang1960老师：
如何在此处定位到某个具体的SHEET表？我只想获取工作簿中某个特定SHEET中的内容而不是所有SHEET表。谢谢！   
myFile = Dir(myPath & "\*.xls")

415823168

记下了，下次时间多时再上。呵呵