麻烦高手帮忙汇总几个工作簿。谢谢！

milan_dw

本人做教学管理工作，经常需要将各专业填好的表格进行汇总（例如将附件中的“1、2、3、4”四个工作簿汇总成“完成”工作簿）。平时只是用复制粘贴进行汇总，费时费力。觉得应该有简洁的办法可以将多工作簿进行汇总。刚刚发现这么好的论坛，也简单看了别人的提问和回答，觉得这里高手满多的。由于本人恰巧正需要此技巧，来不及多看其他帖了，所以特发此帖向高手求助。待有时间再潜水学习。
多谢了！

[ 本帖最后由 milan_dw 于 2009-3-21 14:56 编辑 ]

milan_dw

有没有能帮忙的啊？

ueu

怎样汇总，汇总什么——楼主说下先

milan_dw

就是把附件中的四个表格内容汇总到一个表里。

klas_as

按住alt依次单击F11、I、M，复制并运行下面的代码。   
Sub 多工作簿汇总()
    Dim wk As Workbook, lr As Long, lr1 As Long, i As Integer, Filename, a
    Application.ScreenUpdating = False
    ChDrive "C"                                        '改变当前的驱动器，这里假设是C盘，请自己设定
    ChDir ThisWorkbook.Path                            '改变当前文件夹，这里假设是本工作簿路径，请自己设定
    Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls),*.xls", Title:="请选择文件", MultiSelect:=True)
    If TypeName(Filename) = "Boolean" Then Exit Sub
    Range("a1:l65536") = ""
    For i = 1 To UBound(Filename)
        a = Split(Filename(i), "\")
        If a(UBound(a)) <> ThisWorkbook.Name Then
            Set wk = GetObject(Filename(i))
            With wk.Sheets(1)
              lr = .Range("a65536").End(xlUp).Row
              lr1 = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1
              .Range("a1:l" & lr).Copy ThisWorkbook.Sheets(1).Range("a" & lr1)
            End With
        End If
        wk.Close False
    Next i
    Application.ScreenUpdating = True
    MsgBox "汇总完毕"
End Sub

[ 本帖最后由 klas_as 于 2008-11-28 14:28 编辑 ]

milan_dw

非常感谢您的回复！！
但是还有些问题没搞明白，您有qq吗？想单独请教一下！

zhong_chen

谢谢分享，学习！