关于将不同工作簿中格式相同工作表合并到另一工作簿中的代码再讨论

以前的操作方式是首先将要提取数据工作簿打开,获得要复制的区域,然后再激活目标工作簿,将数据复制进去,时间上太慢,现在学会了创建工作簿对象,由于不需要在源工作簿中写入数据,只是取得数据即可,所以不需打开源工作簿,利用创建工作簿对象即可.

再一个,既然格式相同,往往源工作簿的文件名也具有相似的命名规则,再者,即使是不相似也无所谓,可以通过创建一个文件搜索对象,在指定文件夹中搜索特定文件,然后将其保存到数组中,利用它就可以创建工作簿对象.

先看一下工作簿所在的文件夹样式:

这是把所有需合并的工作簿都放在了同一文件夹下,(一会再考虑如果在不同文件夹下,是否可行?!!)

现在要求做的是将xx***.xls合并到英语工作簿中,以便于统计学分等.比如统计每个学生(按学籍号)的实修学分,这就可以用到条件求和,分析出每个学生的最终学分看是否够毕业的条件.

源程序如下:

Sub 如何将多个工作簿中格式一致的工作表数据合并到同一工作簿中()
    '首先获得需要合并的工作簿文件名
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim i As Integer, xls() As String
    Dim sr As FileSearch '定义一个文件搜索对象
    Set sr = Application.FileSearch
    sr.LookIn = "E:胶州一中" '注意路径，换成你实际的路径
    sr.Filename = "xx*.xls" '搜索所有文件
    sr.Execute '执行搜索
    ReDim xls(sr.FoundFiles.Count)
    For i = 1 To sr.FoundFiles.Count
        xls(i) = sr.FoundFiles(i) '因为下面需要打开指定路径下的文件,故就不需再去路径名了,直接将完整路径输入即可.
        Debug.Print xls(i)
    Next
    '设置一个工作簿对象,获取各学段各学科的学分数据并将其复制到同一工作簿中
    Dim wb As Workbook, j As Integer, TotalR As Integer
    Debug.Print ActiveWorkbook.Name
    For i = 1 To sr.FoundFiles.Count
        TotalR = Range("A65536").End(xlUp).Row
        Set wb = GetObject(xls(i))
        With wb.Sheets(1)
            .Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column)).Copy
        End With
        Range(Cells(TotalR + 1, 1), Cells(TotalR + 1, 1)).PasteSpecial xlPasteAll
        TotalR = Range("A65536").End(xlUp).Row
        Debug.Print TotalR
        Application.CutCopyMode = False
        wb.Close savechanges:=False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.CutCopyMode = True
    Cells.Columns.AutoFit
End Sub

 今天你菊子曰了么？