|
楼主,元旦快乐!——本坛大神 duquancai 老师及其他几位老师早有精彩代码免费传世。
请试试下面的杜老师的代码(某略改,注意将第 5 行代码的文件夹名称自己改一下!):
- Sub FileMerge()
- 'Code by duquancai
- Dim r As Range
- Set r = Documents.Add.Range(Start:=0, End:=0)
- 'Loop-Folders(Code by duquancai)
- Dim pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, stxt$
- pPath = "D:\ZSOSR"
- Set fso = CreateObject("Scripting.FileSystemObject")
- top = 1
- ReDim Stack(0 To top)
- Do While top >= 1
- For Each f In fso.getFolder(pPath).Files
- stxt = f.Path
- If stxt Like "*.docx" Then
- With r
- Selection.InsertFile FileName:=stxt
- End With
- End If
- Next
- For Each fd In fso.getFolder(pPath).subFolders
- Stack(top) = fd.Path
- top = top + 1
- If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
- Next
- If top > 0 Then pPath = Stack(top - 1): top = top - 1
- Loop
- Set f = Nothing
- Set fd = Nothing
- Set fso = Nothing
- msgbox"Complete!",0+48
- End Sub
复制代码 |
|