Sub hebin()
Dim MyPath As String
Dim MyName As String
Dim AWbName As String '路径,名称,活动工作簿名称

Dim wb As Workbook, WbN As String '工作簿,工作簿名称和数量
Dim ss As Worksheet '当前sheet
Dim ws As Worksheet '待处理sheet

Dim Num As Long '待处理工作簿数量

Dim ext As String '扩展名
Dim extn As Long '护展名长度

Dim sn As Long 'sheet循环变量

ext = "*.xlsx"'此处是excel2007以上版本所用扩展名,如果是excel2003则应改为ext="*.xls", extn=4

extn = 5

Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path '当前workbook路径
MyName = Dir(MyPath & "\" & ext) '当前路径下扩展名为ext的文件
AWbName = ActiveWorkbook.Name '当前workbook名称

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then
   Set wb = Workbooks.Open(MyPath & "\" & MyName) '打开扩展名为ext的文件

   For sn = 1 To Workbooks(1).Sheets.Count
    'Workbooks(1).Activate
    'Workbooks(1).Sheets(sn).Select
    Set ss = Workbooks(1).Sheets(sn)
    Set ws = wb.Sheets(sn)
    Call cpsheet(ss, ws, MyName, extn)
   Next sn

    Num = Num + 1 '文件计数
    WbN = WbN & Chr(13) & wb.Name
    wb.Close False
End If

MyName = Dir

Loop

Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

Sub cpsheet(ByRef sesheet As Worksheet, wosheet As Worksheet, strs As String, en As Long) '复制sheet
Dim ss1 As Worksheet '当前sheet
Dim ws1 As Worksheet '待处理sheet
Dim i As Long '行循环变量
Dim j As Long '列循环变量

Dim ssr As Long '当前sheet最下面行
Dim wsr As Long '待处理sheet最下面行
Dim wsc As Long '待处理sheet最右边列

Set ss1 = sesheet
Set ws1 = wosheet

'ss1.Select '使ss1成为当前sheet

With ss1.UsedRange
ssr = .Rows.Count + .Row - 1 '当前sheet最大行数
End With

With ws1.UsedRange
    wsr = .Rows.Count + .Row - 1 '待处理sheet最大行数
    wsc = .Columns.Count + .Column - 1 '待处理sheet最大列数
End With

ss1.Cells(ssr + 1, 1) = Left(strs, Len(strs) - en) '隔行显示待处理workbook名称

For i = 1 To wsr
    For j = 1 To wsc
       ss1.Cells(ssr + 1 + i, j) = ws1.Cells(i, j) '逐个单元格复制
    Next j
Next i

End Sub