|
Sub 包括子文件夹的综合复制()
Dim MyName, Dic, Did, i, MyFileName, ke, x&, fld, ph$
Dim sh As Worksheet
Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象
Set Did = CreateObject("Scripting.Dictionary")
Set fld = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0)
If Not fld Is Nothing Then ph = fld.self.Path & "\"
Dic.Add (ph), ""
i = 0
Do While i < Dic.Count
ke = Dic.keys '开始遍历字典
MyName = Dir(ke(i), vbDirectory) '查找目录
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(ke(i) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
Dic.Add (ke(i) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
i = i + 1
Loop
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ke In Dic.keys
MyFileName = Dir(ke & "*.xls*")
Do While MyFileName <> ""
If MyFileName <> ThisWorkbook.Name Then Did.Add (ke & MyFileName), ""
MyFileName = Dir
Loop
Next
For Each ke In Did.keys
With Workbooks.Open(ke)
For Each sh In .Sheets
x = ThisWorkbook.Sheets.Count
If sh.Visible = xlSheetVisible Then sh.Copy after:=ThisWorkbook.Sheets(x)
Next
.Close False
End With
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub |
|