废话不多说直接上VBA的代码，代码亲测可以合成多个工作薄到一个SHEET上，可能根据个人需要修改的地方有以下两处： 1． '文件所在的文件夹路径,可修改为相应的文件夹 MyPath = \
这个根据个人的情况更换一下所需合成工作薄的目录 2．
'在列A中复制该文件的名称 'With sourceRange
'BaseWks.Cells(rnum, \A\ 'Resize(.Rows.Count).Value = MyFiles(FNum)
'End With
'设置目标区域(destrange)
Set destrange = BaseWks.Range(\A\
上面的四行代码是被注释掉的，这四行代码如果打开在A列就会打印出这一行表格是来自哪个文件，如果需要打开这个功能的话，还需要将BaseWks.Range(\A\中的“A”修改成“B”
Sub UnionWorksheets()
Application.ScreenUpdating = False Dim lj As String
Dim dirname As String Dim nm As String
lj = ActiveWorkbook.Path nm = ActiveWorkbook.Name dirname = Dir(lj & \
Cells.Clear
Do While dirname <> \ If dirname <> nm Then
Workbooks.Open Filename:=lj & \
Workbooks(nm).Activate
'复制新打开工作簿的第一个工作表的已用区域到当前工作表 Workbooks(dirname).Sheets(1).UsedRange.Copy _ Range(\
Workbooks(dirname).Close False End If
dirname = Dir Loop
End Sub
Function RDB_Last(choice As Integer, rng As Range)
' 选择 1 代表最后一行. ' 选择 2 代表最后一列.
' 选择 3 代表最后一个单元格. Dim lrw As Long Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:=\
after:=rng.Cells(1), _ Lookat:=xlPart, _
LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).row On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:=\
after:=rng.Cells(1), _ Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:=\
after:=rng.Cells(1), _ Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).row On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:=\
after:=rng.Cells(1), _ Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False) If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False) Err.Clear End If
On Error GoTo 0
End Select End Function
Sub MergeAllWorkbooks()
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
'文件所在的文件夹路径,可修改为相应的文件夹 MyPath = \
'路径末尾是否有反斜杠,若无则添加 If Right(MyPath, 1) <> \ MyPath = MyPath & \ End If
'如果文件夹中没有Excel文件则退出 FilesInPath = Dir(MyPath & \
If FilesInPath = \
MsgBox \ 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
'创建带有一个工作表的新工作簿
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1
'遍历数组(myFiles)中的所有文件 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)) On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = mybook.Worksheets(1).UsedRange End With
If Err.Number > 0 Then Err.Clear
相关推荐：
loading