Inserting Sub Documents with a Loop in vba

[EMONTES149]

Help Needed With step 5.

The following macro lets the user select a project folder with ".doc" files then inserts these subdocuments into a Master Document. It works exactly the way I envision it; however, I have to hard code the path. Can someone help me modify the code so that It can loop through all the files in the folder regardless of file name. I do not want to hard code the path with file name because the files vary from project to project. I am not a code writer, but an architect so any guidance is very much appreciated.

Sub CreatingRelativeSubDocuments()


' Step 1 - The following code sets the variables and lets Excel Know that it will be controlling Word.


Dim fldr As FileDialog
Dim objWord
Dim objDoc
Dim SaveName As String


SaveName = (Sheets("Header-Footer").Range("H5") & "-" & Sheets("Header-Footer").Range("H6"))

' Step 2 - The following code lets you pick the project folder.

MsgBox "On Next Screen Select Project Folder"

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With


' Step 3 - The following code opens a Word Document so you can begin the Master Spec.

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add



' Step 4 - The following code sets the Word Document to the Outline View and Expands the Sub Document Format.

objWord.Visible = True
objWord.ActiveWindow.ActivePane.View.Type = wdOutlineView
objWord.ActiveDocument.Subdocuments.Expanded = Not objWord.ActiveDocument.Subdocuments.Expanded


' Step 5 - The following code inserts the Sub Documents based on the Folder Path that you picked in Step 2

objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & "" & "011000 - summary.doc"
objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & "" & "012100 - allowances.doc"
objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & "" & "012200 - unit prices.doc"
objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & "" & "012300 - alternates.doc"
objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & "" & "013100 - Project Management and Coordination.doc"

'Step 6 - This returns word to outline view and prepares to save the file


objWord.ActiveWindow.ActivePane.View.Type = wdOutlineView

If objWord.ActiveWindow.View.SplitSpecial = wdPaneNone Then
objWord.ActiveWindow.ActivePane.View.Type = wdNormalView
Else
objWord.ActiveWindow.View.Type = wdNormalView
End If

objWord.ActiveWindow.ActivePane.View.Type = wdOutlineView

'Step 7 - This saves the file to User Defined File Name

MsgBox "Next Select Project Folder and Master Specification File Name"

'Step 8 - this Stops, Quits and releases the Word Application


objWord.ActiveDocument.Close
objWord.Quit


Set objWord = Nothing

End Sub

 

[AlphaFrog]

Try this...

[color=green]' Step 5 - The following code inserts all the Sub Documents from the Folder Path that you picked in Step 2[/color]
[color=darkblue]Dim[/color] strFile [color=darkblue]As[/color] [color=darkblue]String[/color]
FolderName = FolderName & Application.PathSeparator
strFile = Dir(FolderName & "*.doc")
[color=darkblue]Do[/color] [color=darkblue]Until[/color] strFile = ""
    objWord.Selection.Range.Subdocuments.AddFromFile Name:=FolderName & strFile
    strFile = Dir   [color=green]'Next .doc file[/color]
[color=darkblue]Loop[/color]

 

[EMONTES149]

Thank you. This worked perfectly! One issue that I did not forsee is that if the file name exists (which it does) when it saves it it produces a copy. Is there a way to replace the existing file?

 

[EMONTES149]

The following is the first part of the Macro to select the "doc" files and place in the selected project directory. It works fine with the exception that the files selected are copied to the Desktop and the the folder selected which is the DestPath. I cannot figure out step 2 and why it does not copy to the selected folder. Can anyone quide me? my goal is to combine both macros or "subs" to with one button.

Sub RevisedToSelectSubDocsFromMaster2ProjectFolder()

'Step 1 - Set Variables

Dim R As Range
Dim SourcePath As String
Dim DestPath As String
Dim FName As String
Dim FolderName As String



'Step 2 - 'THIS SELECTS THE SPEC SECTIONS BASED ON THE CHECKLIST FROM WORKSHEET "MasterSpecList". THIS WORKS WITH HIDDEN ROWS
'Setup source and dest path (Note: must have a trailing backslash!)
'THE MESSAGE BOX ALLOW STHE ENDU USER TO PICK THE DESTINATION FOLDER

SourcePath = "O:\SYS2\RENOVATIONS\Design\ADMINISTRATION\Specifications\Master Specification Sections" 'THIS NEVER CHANGES
DestPath = FolderName 'ALLOWS USER TO SELECT THE PROJECT FOLDER

MsgBox "On Next Screen Select Project Folder"

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0

End With

'STEP 3 - Visit each used cell in column A OF WORKSHEET "MasterSpecList"
For Each R In Range("A3", Range("A" & Rows.Count).End(xlUp))

If R.EntireRow.Hidden = False Then
R.EntireRow.Offset(1, 0).Select

'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
FName = Dir(SourcePath & R)

'Loop while files found
Do While FName <> ""


'STEP 4 - THIS COPIES THE FILES FROM THE SOURCE PATH TO THE DESTINATION PATH
'Copy the file
FileCopy SourcePath & FName, DestPath & FName

'Search the next file
FName = Dir()

Loop
End If


Next




End Sub