PDA

View Full Version : Loop Through SubFolders Task - Merge Files as Folder Name



dj44
04-10-2016, 03:12 AM
Folks,

good day to all.:)

I am needing assistance on my task that has a loop in it and subfolders.

First my apologies - as I have messed the code up -trying to make it between word and excel.

I am trying to loop through subfolders and do a merge task on each folder.

There are many scripts for merging only one folder.

Now i have borrowed the ideas from here.

http://www.vbaexpress.com/forum/showthread.php?47741-Word-macro-need-to-run-it-from-excel




Sub MergeDocs()

Const wdCollapseEnd As Long = 0, wdPageBreak As Long = 7
Dim objWord As Object, strFile As String, strFile1 As String, strFolder As String

strFolder = "C:\Users\DJ\Desktop\Files" ' This folder has all the subfolders

' Get/Create Word Application object
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Err <> 0 Then Set objWord = CreateObject("Word.Application")

' Trap errors
On Error GoTo exit_



' I am trying to save the Merged file name as the folder name

strFile = Dir$(strFolder & "*.doc*")
strFile1 = strFile

' Merge documents
If Len(strFile) Then
With objWord.Documents.Open(strFolder & strFile, , True).Range
While Len(strFile)
If strFile <> strFile1 Then
With .Characters.Last
.Collapse wdCollapseEnd
.InsertBreak wdPageBreak
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$
Wend
End With
End If

exit_:

objWord.Visible = True
If Err Then MsgBox strFile & vbLf & Err.Description, vbCritical, "Error #" & Err.Number

End Sub





The Excel bit - I need a FSO

This function for looping through the Sub folders
http://www.mrexcel.com/forum/excel-questions/451389-loop-through-all-xls-files-subdirectories-directory.html





Option Explicit

Public Sub Process_Files()

Dim Fso As Scripting.FileSystemObject

Set Fso = New Scripting.FileSystemObject
Process_Files Fso, "C:\Users\DJ\Desktop\Files" ' This folder has lots of sub folders

Set Fso = Nothing

End Sub


Private Sub Process__Files(Fso As Scripting.FileSystemObject, folderPath As String)

Dim Folder As Scripting.Folder, Subfolder As Scripting.Folder, File As Scripting.File
Dim doc as document

Set Folder = Fso.GetFolder(folderPath)

For Each Subfolder In Folder.subfolders
For Each File In Subfolder.Files
If InStr(File.Name, ".docx") Then

' Merge the documents in each folder and create a new file based on folder name

Call MergeDocs ' Call the main procedure above ?

End If
Next
Next

End Sub





Now I have tried all sorts as always before posting for help - I also researched for help on VBA, but made lots of errors.

but I think i have drifted way too far offshore on this one - I will be humbly grateful for any assistance from the pro coders.

If I am on the wrong track please accept my apologies.

What I am trying to do :

In each folder there will be a set of my word files. I would like to merge each set of files - keeping the original formatting.
The new merged file name will be the Name of the folder.

thank you for your valuable time in advance.

I appreciate the time and help

DJ