' Sub for recursing through multiple files in directories, to perform a common task
Sub MassEdit_Loop() 
    Dim MyPath As String, FilesInPath As String, RegEx As String, Template As String, NewFile As String 
    Dim MyFiles() As String 
    Dim FNum As Long 
    Dim MainDoc As Word.Document, MainDoc2 As Word.Document 
    Dim wdApp As Word.Application 
    Dim wdApp2 As Word.Application 
     
    MyPath = "C:\Documents and Settings\beirol\Desktop\Existing" 
    Template = "C:\Documents and Settings\beirol\Desktop\Template\Procedure Template.doc" 
     ' This is the Regex for file searching (e.g. all .doc files in the folder)
    RegEx = "*.doc" 
     
     ' Call upon the Recursive File Name builder
    Dim colFiles As New Collection 
    RecursiveDir colFiles, MyPath, RegEx, True 
     ' Loop through the Filenames to collect them into an Array
    FNum = 0 
    Dim vFile As Variant 
    For Each vFile In colFiles 
        FNum = FNum + 1 
        ReDim Preserve MyFiles(1 To FNum) 
        MyFiles(FNum) = vFile 
    Next vFile 
     
    If FNum > 0 Then 
        For FNum = LBound(MyFiles) To UBound(MyFiles) 
            On Error Resume Next 
             
             ' Open template
            Set wdApp = CreateObject("word.Application") 
            wdApp.Visible = False 
            wdApp.ScreenUpdating = False 
            Set MainDoc = wdApp.Documents.Open(Template) 
             
             ' Open source document
            Set wdApp2 = CreateObject("word.Application") 
            wdApp2.Visible = False 
            wdApp2.ScreenUpdating = False 
            Set MainDoc2 = wdApp2.Documents.Open(MyFiles(FNum)) 
             
             ' Select all data from source doc
             ' Copy data
            wdApp2.Selection.WholeStory 
            wdApp2.Selection.Copy 
            wdApp.Selection.Paste 
             
             'Format the content to Guidelines
            wdApp.Selection.WholeStory 
            wdApp.Selection.Font.Name = "Verdana" 
            wdApp.Selection.Font.Size = 10 
            wdApp.Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly 
            wdApp.Selection.ParagraphFormat.LineSpacing = 12 
             
             'set word back to normal
            wdApp2.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges 
            wdApp2.Application.Quit wdDoNotSaveChanges 
             
            wdApp2.Visible = True 
            wdApp2.ScreenUpdating = True 
            Set wdApp2 = Nothing 
             
             
            justFileName = Dir(MyFiles(FNum)) 
            NewFile = "C:\Documents and Settings\beirol\Desktop\Converted\" + justFileName 
            wdApp.ActiveDocument.SaveAs Filename:=NewFile 
            wdApp.ActiveDocument.Close 
            wdApp.Application.Quit wdDoNotSaveChanges 
             
            wdApp.Visible = True 
            wdApp.ScreenUpdating = True 
            Set wdApp = Nothing 
             
        Next FNum 
    End If 
    End Sub