|
Excel多个工作簿中的工作表合并到一个工作簿中 转
LHY：方法2比较好，是我需要的Excel多个工作簿中的工作表合并到一个工作簿中！^_^
'有时，需要将多个Excel工作簿中的工作表合并到一个工作簿中。有多种合并工作簿的情形，下面先给出一种合并多个工作簿的VBA范例，供参考。
方法1
Sub CombineWorkbooks()
Dim wk As Workbook
Dim sh As Worksheet
Dim strFileName As String
Dim strFileDir As String
Dim nm As String
nm = ThisWorkbook.Name
strFileDir = ThisWorkbook.path & "\"
Application.ScreenUpdating = False
strFileName = Dir(strFileDir & "*.xls")
Do While strFileName <> vbNullString
If strFileName <> nm Then
MsgBox strFileName
Set wk = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29) '取主文件名,除掉.XLS
For Each sh In wk.Sheets
sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'工作表命名,以工作表所在文件名为类
If wk.Sheets.Count > 1 Then
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = strFileName & sh.Name
Else
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = strFileName
End If
Next
wk.Close SaveChanges:=False
End If
strFileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
方法2
Sub UnWorksheets()
Application.ScreenUpdating = False
Dim lj As String
Dim dirname As String
Dim nm As String
Dim sname As String
Dim i As Integer, ii As Integer
lj = ActiveWorkbook.path
nm = ActiveWorkbook.Name
dirname = Dir(lj & "\*.xls") '查找文件
Do While dirname <> ""
If dirname <> nm Then
Workbooks.Open Filename:=lj & "\" & dirname '打开文件
ii = ActiveWorkbook.Sheets.Count '统计工作表个数
'复制新打开工作簿的每一个工作表到当前工作表(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))最后一个后面
For i = 1 To ii
Workbooks(dirname).Sheets(i).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
End Sub
'在同一文件夹下有多个工作簿，其中有一个用于汇总的工作簿，要求将除该汇总工作簿外的其它
'工作簿中的每一张工作表的数据汇总到该汇总工作簿中?
Sub UnionWorksheets()
Application.ScreenUpdating = False
Dim lj As String
Dim dirname As String
Dim nm As String
Dim i As Integer, ii As Integer
lj = ActiveWorkbook.path
nm = ActiveWorkbook.Name
dirname = Dir(lj & "\*.xls")
Cells.Clear
Do While dirname <> ""
If dirname <> nm Then
Workbooks.Open Filename:=lj & "\" & dirname
ii = ActiveWorkbook.Sheets.Count
Workbooks(nm).Activate
'复制新打开工作簿的每一个工作表的已用区域到当前工作表
For i = 1 To ii
Workbooks(dirname).Sheets(i).UsedRange.Copy _
Range("a65536").End(xlUp).Offset(2, 0)
Next
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
End Sub |
|
