Sub 合并当前目录下所有工作簿的全部工作表() Dim MyPath, MyName, AWbName 定义变量但未指定变量类型这样一般是不规范的 Dim Wb As Workbook, WbN As String 定义变量wb为工作簿类型wbn为字符型 Dim G As Long 定义G为长整型 Dim Num, ini As Long 定义num并定义和声明ini为长整型注意num类型未定 Application.ScreenUpdating False 关闭屏幕刷新 MyPath ActiveWorkbook.Path 将当前工作簿的路径赋值给mypath MyName Dir(MyPath \ *.xls) 将活动工作簿的名字加上.xls后赋值给myname AWbName ActiveWorkbook.Name 将激活工作簿的文件名赋值给awbname Num 0 ini 0 Do While MyName 运行下面的do while循环直到myname的值为空。 If MyName AWbName Then 如果myname与awbname的值不同则运行下一个end if前的语句 Set Wb Workbooks.Open(MyPath \ MyName) 打开mypath路径下名字为myname变量值的工作簿并将其赋给wb Num Num 1 对num累加 With Workbooks(1).ActiveSheet 对已打开的所有工作簿中的第一个工作簿中的被激活的工作表运用with语句 If ini 0 Then Wb.Sheets(1).Range(Wb.Sheets(1).Cells(1, 1), Wb.Sheets(1).Cells(1, Wb.Sheets(1).UsedRange.Columns.Count)).Copy .Cells(1, 1) 将wb工作簿中第一个工作表的第一行有应用痕迹的单元格内容复制到Workbooks(1).ActiveSheet的相同位置 Wb.Sheets(1).Range(Wb.Sheets(1).Cells(2, 1), Wb.Sheets(1).Cells(2, Wb.Sheets(1).UsedRange.Columns.Count)).Copy .Cells(2, 1) 将wb工作簿中第一个工作表的第二行有应用痕迹的单元格内容复制到Workbooks(1).ActiveSheet的相同位置 Wb.Sheets(1).Range(Wb.Sheets(1).Cells(3, 1), Wb.Sheets(1).Cells(3, Wb.Sheets(1).UsedRange.Columns.Count)).Copy .Cells(3, 1) 将wb工作簿中第一个工作表的第三行有应用痕迹的单元格内容复制到Workbooks(1).ActiveSheet的相同位置 Wb.Sheets(1).Range(Wb.Sheets(1).Cells(4, 1), Wb.Sheets(1).Cells(4, Wb.Sheets(1).UsedRange.Columns.Count)).Copy .Cells(4, 1) 将wb工作簿中第一个工作表的第四行有应用痕迹的单元格内容复制到Workbooks(1).ActiveSheet的相同位置 ini 1 End If For G 1 To Sheets.Count 在Workbooks(1).ActiveSheet的所有sheet中循环。 Wb.Sheets(G).Range(Wb.Sheets(G).Cells(5, 1), Wb.Sheets(G).Cells(Wb.Sheets(G).UsedRange.Rows.Count, Wb.Sheets(G).UsedRange.Columns.Count)).Copy .Cells(.Range(A65536).End(xlUp).Row 1, 1) Wb.Sheets(G).Range(Wb.Sheets(G).Cells(5, 1) 第一个参数表示从第几行开始复制 将WB中的A2到最后一行最后一列的非空单元格的内容复制到Workbooks(1).ActiveSheet中每次从Workbooks(1).ActiveSheet的最后一个非空行开始粘贴 Next WbN WbN Chr(13) Wb.Name 将wbn的值加上空格和wb的名称后赋值给wbn Wb.Close False 将wb关闭 End With End If MyName Dir Loop Range(A1).Select 选中当前工作簿的第一个单元格 Application.ScreenUpdating True 开启屏幕刷新 MsgBox 共合并了 Num 个工作薄下的全部工作表。如下 Chr(13) WbN, vbInformation, 提示 给出最后提示 End Sub