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
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