- 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
来源: http://www.phpxs.com/code/1008748/