代码如下：
Sub 文件合并()
Dim wb As Workbook, sh As Worksheet, pT As String, wb2 As Workbook, t
t = Timer
'检测是否有无关工作簿被打开
If Workbooks.Count > 1 Then
MsgBox "关闭打开的其他工作簿"
Exit Sub
End If
'指定文件所在文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub '如果按了取消或X关闭了对话框，则直接退出
pT = .SelectedItems(1)
End With
Application.ScreenUpdating = False '关闭屏幕刷新
Application.DisplayAlerts = False '关闭对话框
'创建一个新工作表，名为New.xls
Set wb = Workbooks.Add
shJS = wb.Worksheets.Count
fn = Dir(pT & "\*.xls")
While fn <> ""
If fn = wb.Name Then GoTo gg
i = i + 1
If i > shJS Then
Set sh = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
End If
Set wb2 = Workbooks.Open(fn, ReadOnly = True)
wb2.Worksheets(1).Cells.Copy wb.Worksheets(i).Cells
wb.Worksheets(i).Name = Left(fn, Len(fn) - 4)
wb2.Close
gg:
fn = Dir
Wend
wb.SaveAs pT & "\new.xls"
wb.Close
Application.ScreenUpdating = True '打开屏幕刷新
Application.DisplayAlerts = True '打开对话框
MsgBox "共用时" & Timer - t & "秒。生成新文件new.xls"
End Sub