Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim FirstCell As String
Dim totalrows%
Dim i%
Dim n%
n = 2
'文件所在的文件夹路径,可修改为相应的文件夹
MyPath = "E:\合并文件"
'路径末尾是否有反斜杠,若无则添加
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'如果文件夹中没有Excel文件则退出
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'使用文件夹中的Excel文件列表填充数组 (MyFiles)
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
'修改屏幕更新,计算模式和启用事件的状态
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
n = Sheets.Count '计算工作表数目
fn = ActiveWorkbook.Name
For i = 1 To n '循环进行多工作表合并
Sheets(i).Select '原文件表选择
totalrows = WorksheetFunction.CountA(Range("A:A")) '原表行数
Range(Cells(2, 1), Cells(totalrows, 200)).Select
Selection.Copy
Windows("多EXCEL文件合并器.xls").Activate
Sheets(i).Select '目标表选择
targetrows = WorksheetFunction.CountA(Range("A:A")) '目标行数
Cells(targetrows + 1, 1).Select
ActiveSheet.Paste
Windows(fn).Activate
Application.CutCopyMode = False
Sheets.Add After:=Sheets(Sheets.Count) '新增空工作表(当工作表多于六个时添加)
Next i
' ActiveWindow.Close savechanges:=False
mybook.Close savechanges:=False '关闭工作表，但不保存改变
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'恢复屏幕更新,计算模式和启用事件的状态
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
________________________________________________________________________
Sub B多表格文件合并器_仅适用于2003()
' 由于本EXCEL为2003版 ，故只支持行数为6万行的数据合并
'本程序通过VBA FileSearch 函数遍历 ，但office 2007版无此函数，故只适用于2003版
Dim n%
n = 2
With Application.FileSearch
.LookIn = "E:\合并文件"
.Filename = "*.xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(i))
n = Sheets.Count
fn = ActiveWorkbook.Name
For j = 1 To n '循环进行多工作表合并
Sheets(j).Select '原工作表选择
totalrows = WorksheetFunction.CountA(Range("A:A")) '原表行数
Range(Cells(2, 1), Cells(totalrows, 200)).Select
Selection.Copy
Windows("多EXCEL文件合并器.xls").Activate
Sheets(j).Select '目标工作表选择
targetrows = WorksheetFunction.CountA(Range("A:A")) '目标行数
Cells(targetrows + 1, 1).Select
ActiveSheet.Paste
Windows(fn).Activate
Application.CutCopyMode = False
Sheets.Add After:=Sheets(Sheets.Count)
Next j
ActiveWindow.Close savechanges:=False
