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

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

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

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





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

现在要求做的是将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



今天你菊子曰了么？