Hi, I need some help combining the two subs below. The first Sub ExcelRangeToWord has been placed in the sheet 1 tab and the Sub DocSearch has been placed in the This Workbook tab.

I would like both of them to run at the same time. Right now if you run the first one, it will open the specific Word document and copy the tables over. You then have to save and close the word document and run the second sub.

I would like them both to run and then perform a Save As to a different location so the original word document is untouched.

Thank you,
Colby

Sub ExcelRangeToWord()
    
    'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
    'NOTE: Must have Word Object Library Active in Order to Run _
     (VBE > Tools > References > Microsoft Word 12.0 Object Library)
    'SOURCE: www.TheSpreadsheetGuru.com
    
'    Dim tbl       As Excel.Range
    Dim WordApp   As Word.Application
    Dim myDoc     As Word.Document
    Dim WordTable As Word.Table
    Dim ws        As Worksheet
    
    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
'    'Copy Range from Excel
'      Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).listobjects("Table1").Range
    
    'Create an Instance of MS Word
    On Error Resume Next
    
    'Is MS Word already opened?
    Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
    Err.Clear
    
    'If MS Word is not already open then open MS Word
    If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
    If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
    End If
    
    On Error GoTo 0
    
    'Make MS Word Visible and Active
    WordApp.Visible = True
    WordApp.Activate
    
    'Create a New Document
    'Set myDoc = WordApp.Documents.Add
    Set myDoc = WordApp.Documents.Open("C:\Users\user\Desktop\Report - Master Template.docx")
    
    For Each ws In ThisWorkbook.Worksheets  'Loop through all worksheets
    
        If ws.ListObjects.Count > 0 Then    'Test if worksheet has a table
        
            ws.ListObjects(1).Range.Copy    'Copy first Table
    
            'Paste Table into MS Word (last Paragraph)
            myDoc.Paragraphs.Last.Range.PasteExcelTable _
                 LinkedToExcel:=False, _
                 WordFormatting:=False, _
                 RTF:=True
                 
                
                
            'Autofit Table so it fits inside Word Document
            myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
            
            'Add paragreaph below each table
            myDoc.Paragraphs.Add myDoc.Paragraphs.Last.Range
    
        End If
    
    Next ws
    
EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    'Clear The Clipboard
    Application.CutCopyMode = False
    
End Sub
Sub DocSearch()
Dim wdApp As Object, wdDoc As Object
Dim SrchRNG As Range, SrchVAL As Range

Set SrchRNG = ThisWorkbook.Sheets("Client Info").Range("B:B").SpecialCells(xlConstants)
    
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("C:\Users\user\Desktop\Report - Master Template.docx")
    
For Each SrchVAL In SrchRNG
    With wdDoc.Content.Find
        .Text = SrchVAL.Text
        .Replacement.Text = SrchVAL.Offset(, 1).Text
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
Next SrchVAL

Set wdApp = Nothing
Set wdDoc = Nothing
End Sub