Find and replace text in a separate Word document from a user input variable

Question

I made a VBA macro that generates a MailMerge from an Excel spreadsheet creating the new document in Word.

I need to run a Find and Replace on a particular phrase ('ANTHXXXX') in the Word document with the user input variable InputtedModuleCode.

The macro runs without errors, but I can't get it to find and replace. I have included the entire macro script below. The relevant line of the script is underneath the comment:

' find and replace module code

...about 10 lines from the bottom of the script.

Sub AAMerge()
'
' AAMerge Macro
'

'
    'Prompt user to input Module Code
    Dim InputtedModuleCode As String
    InputtedModuleCode = InputBox("Enter Module Code here, e.g. ANTH1001")
    'Prompt user to input Module Code
    Dim InputtedSubmissionDeadline As String
    InputtedSubmissionDeadline = InputBox("Enter essay submission deadline. Must be format dd/mm/yyyy hh:mm:ss")
    'Copy data into new spreadsheet
    Cells.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 10
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    ' Move GradeMark Grade Column
    Columns("H:H").Select
    Selection.Copy
    Columns("P:P").Select
    ActiveSheet.Paste
    ' Delete Overlap/Internet Overlap/Publications Overlap/Student Papers Overlap columns
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Selection.Delete Shift:=xlToLeft
    Columns("F:J").Select
    Selection.Delete Shift:=xlToLeft
    ' insert Portico SCN formula
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "SCN (Portico)"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-5],""_"",(LEFT(RC[-4],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,6,FALSE),"""")"
    Range("F3").Select
    Dim LR As Integer
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillDefault
    ' insert Portico student email
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Email (Portico)"
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-6],""_"",(LEFT(RC[-5],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,7,FALSE),"""")"
    Range("G3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("G3").AutoFill Destination:=Range("G3:G" & LR), Type:=xlFillDefault
    ' insert Portico student department name
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "Dept (Portico)"
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-7],""_"",(LEFT(RC[-6],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,9,FALSE),"""")"
    Range("H3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("H3").AutoFill Destination:=Range("H3:H" & LR), Type:=xlFillDefault
    ' Format column headers and widths
    Rows("2:2").Select
    Selection.Font.Bold = True
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    'Sort alphabetically by surname/firstname
    Range("A3").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A3:A" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:H" & LR)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ' Move SCN column from Column G to Column C
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight
    Columns("G:G").Select
    Selection.Cut Destination:=Columns("C:C")
    Columns("C:C").Select
    ' Remove ' at ' from Date Uploaded column
    Columns("F").Replace What:=" at ", Replacement:=" ", LookAt:=xlPart
    ' Format date and add extra date columns
    Columns("F:F").Select
    Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Extension Date"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "Essay Deadline"
    Columns("F:G").Select
    Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
    ' Add user inputted submission date
    Range("F3").Select
    ActiveCell.FormulaR1C1 = CDate(InputtedSubmissionDeadline)
        Range("F3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillCopy
     ' Cleanup column width and add extra column
         Columns("F:F").EntireColumn.AutoFit
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "Days late"
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "Penalty (%pts)"
    ' Number of days late column
    Range("I3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF((RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2]))<=0), 0, (ROUNDUP(RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2])),0)))"
    Range("I3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("I3").AutoFill Destination:=Range("I3:I" & LR), Type:=xlFillDefault
     ' Penalty %pts column
         Range("J3").Select
    ActiveCell.FormulaR1C1 = _
        "=(IF(RC[-1]>7,100,(IF(RC[-1]>1,10,IF(RC[-1]>0,5,0)))))"
    Range("J3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("J3").AutoFill Destination:=Range("J3:J" & LR), Type:=xlFillDefault
     ' Add marks columns
        Range("M2").Select
    ActiveCell.FormulaR1C1 = "1stM Grade"
    Range("N2").Select
    ActiveCell.FormulaR1C1 = "2ndM Grade"
    Range("O2").Select
    ActiveCell.FormulaR1C1 = "Final Grade"
    Range("O2").Select
    ActiveCell.FormulaR1C1 = "Agreed Grade"
      ' Add final grade colum
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "Final Grade (after penalty)"
    Range("P3").Select
    ActiveCell.FormulaR1C1 = "=MAX(0,(RC[-1]-RC[-6]))"
    Range("P3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("P3").AutoFill Destination:=Range("P3:P" & LR), Type:=xlFillDefault
     ' Add column with formatted submission deadline date that can be read by MailMerge in word
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "Submission Deadline (formatted)"
    Range("Q3").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-11],""dd-mmm-YYYY HH:mm:ss"")"
    Range("Q3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("Q3").AutoFill Destination:=Range("Q3:Q" & LR), Type:=xlFillDefault
    ' Add column with formatted submission deadline date that can be read by MailMerge in word
    Range("R2").Select
    ActiveCell.FormulaR1C1 = "Date Uploaded (formatted)"
    Range("R3").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-10], ""dd-mmm-YYYY HH:mm:ss"")"
    Range("R3").Select
     LR = Range("A" & Rows.Count).End(xlUp).Row
     Range("R3").AutoFill Destination:=Range("R3:R" & LR), Type:=xlFillDefault
    'Save file
    ActiveWorkbook.SaveAs Filename:="N:\EssaySubTrial\" & InputtedModuleCode & " Datasheet " & _
    Format(Now(), "yyyy-mm-dd HHmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:="", _
    WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    Sheets("Sheet3").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Sheet2").Select
    ActiveWindow.SelectedSheets.Delete

    ' do Mailmerge

    Dim wdOutputName, wdInputName As String
    wdOutputName = ThisWorkbook.Path & "\Coversheet " & Format(Date, "d mmm yyyy")
    wdInputName = ThisWorkbook.Path & "\coursework-coversheet-template-merged-updated.docx"

    ' open the mail merge layout file
    Dim wdDoc As Object
    Set wdDoc = GetObject(wdInputName, "Word.document")
    wdDoc.Application.Visible = True

    With wdDoc.MailMerge
         .MainDocumentType = wdFormLetters
         .Destination = wdSendToNewDocument
         .SuppressBlankLines = True
         .Execute Pause:=False
    End With

    ' find and replace module code
    wdDoc.Application.ActiveDocument.Content.Find.Execute "ANTHXXXX", ReplaceWith:=InputtedModuleCode, Replace:=wdReplaceAll

    ' show and save output file
    wdDoc.Application.Visible = True
    wdDoc.Application.ActiveDocument.SaveAs wdOutputName

    ' cleanup
    wdDoc.Close SaveChanges:=False
    Set wdDoc = Nothing

End Sub

Can you tell us what you've tried and if there is a reason why you cannot merge in the ANTHXXXX instead of doing a find/replace? — James Snell

CuberChase CuberChase · Accepted Answer · 2013-01-21T12:17:46

I haven't check the remainder of the code but if your problem is merely the Find and replace at the bottom of the code then the following should do the job (setting the replacement from a string shouldn't matter):

    'I'd recommend leaving all these options in
    With wdDoc.Application.Selection.Find
        .ClearFormatting
        .Text = "ANTHXXXX"
        .Replacement.Text = InputtedModuleCode
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With

One other thing if you're interested, the code wdDoc.Application.ActiveDocument.SaveAs does exactly the same thing as wdDoc.SaveAs.

Find and replace text in a separate Word document from a user input variable

1 Answers