|
Sub 将同路径下的多张工作薄中的工作表合并到当前活动的工作表()
Application.ScreenUpdating = False
Dim lj, dirname, nm
Dim a As Long
Dim i As Long
Dim Directory As String
Dim stMedd As String
stMedd = "请选择拆分文件保存目录:" '选择目录
Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
If Not obMapp Is Nothing Then
Directory = obMapp.self.Path & "\"
Else
Exit Sub
End If
' lj = ActiveWorkbook.Path
nm = ActiveWorkbook.Name
dirname = Dir(Directory & "*.xls")
Do While dirname <> ""
If dirname <> nm Then '不能是当前的工作簿
Workbooks.Open Filename:=Directory & dirname
a = Sheets.Count '读当前工作薄中的所有的工作表
Workbooks(nm).Activate
For i = 1 To a
Workbooks(dirname).Sheets(i).UsedRange.Copy Range("a65536").End(xlUp).Offset(1, 0) '复制新打开的工作簿的第一个工作表的已用区域到rng
Next i
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
End Sub |
|