' 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 RngStry As Word.Range, Fld As Word.Field 
    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 
         ' Start Word
        Set wdApp = CreateObject("word.Application") 
        With wdApp 
            .Visible = False 
            .ScreenUpdating = False 
            For FNum = LBound(MyFiles) To UBound(MyFiles) 
                On Error Resume Next 
                justFileName = Dir(MyFiles(FNum)) 
                NewFile = "C:\Documents and Settings\beirol\Desktop\Converted\" + justFileName 
                Set MainDoc = .Documents.Open(FileName:=Template, AddToRecentFiles:=False) 
 
                 ' Open source document
                Set MainDoc2 = .Documents.Open(FileName:=MyFiles(FNum), AddToRecentFiles:=False) 
 
                 ' Select all data from source doc
                 ' Copy data
                MainDoc2.WholeStory.Copy 
                MainDoc2.Close SaveChanges:=wdDoNotSaveChanges 
                With MainDoc 
                    With .Range 
                        .Paste 
                         'Format the content to Guidelines
                        .Font.Name = "Verdana" 
                        .Font.Size = 10 
                        .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly 
                        .ParagraphFormat.LineSpacing = 12 
                    End With 
                     ' update all fields in document
                    For Each RngStry In .StoryRanges 
                        For Each Fld In RngStry.Fields 
                            Fld.Update 
                        Next 
                    Next 
                    .SaveAs FileName:=NewFile, AddToRecentFiles:=False 
                    .Close 
                End With 
            Next FNum 
            .Quit 
        End With 
        Set wdApp = Nothing 
    End If 
End Sub