命令从下面第一个Sub开始：
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As StringDim G As Long, k As IntegerDim Num As LongDim BOX As StringApplication.ScreenUpdating = FalseMyPath = ActiveWorkbook.PathMyName = Dir(MyPath & "\" & "*.xls")AWbName = ActiveWorkbook.NameNum = 0ii = 0Do While MyName <> ""If MyName <> AWbName ThenSet Wb = Workbooks.Open(MyPath & "\" & MyName)Num = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1) = Left(MyName, Len(MyName) - 4)For G = 1 To Sheets.Countk = k + 1If k = 1 Then '如果第一次复制，被复制文件就进行复制前面几行标题栏Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row, 2) '1是从第一列开始黏贴If .Range("B" & Rows.Count).End(xlUp).Row > 100000 ThenMsgBox "如下表格错误，超过一万行" & Chr(13) & Wb.NameEnd Ifii = .Range("B" & Rows.Count).End(xlUp).RowElse '否则就下移三行（假设标题栏三行） .下行代码中的Offset(3) 就是下移三行再复制，所以要下移几行改这个3为几就可以了Wb.Sheets(G).UsedRange.Offset(1).Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 2) '+1是从有数行的下一行开始黏贴If .Range("B" & Rows.Count).End(xlUp).Row > (ii + 100000) ThenMsgBox "如下表格错误，超过一万行" & Chr(13) & Wb.NameEnd Ifii = .Range("B" & Rows.Count).End(xlUp).RowEnd IfNextWbN = WbN & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMyName = DirLoopRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
