Inserting Sub Documents with a Loop in vba

EMONTES149

New Member
Joined
Dec 20, 2016
Messages
8
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
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,378
Try this...

Code:
[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

New Member
Joined
Dec 20, 2016
Messages
8
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

New Member
Joined
Dec 20, 2016
Messages
8
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,469
Messages
5,596,328
Members
414,054
Latest member
Sameer50

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top