从用户输入变量中查找和替换单独的Word文档中的文本

Question

我制作了一个VBA宏，该宏从Excel电子表格中生成MailMerge，从而在Word中创建新文档。

我需要使用用户输入变量InputtedModuleCode在Word文档中的特定短语（'ANTHXXXX'）上运行查找和替换。

宏运行时没有错误，但是我无法找到并替换它。我在下面包括了整个宏脚本。脚本的相关行在注释下面：

'查找并替换模块代码

...从脚本底部开始大约10行。

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

Answer 1

我没有检查代码的其余部分，但是如果您的问题只是代码底部的“查找并替换”，则应执行以下操作（从字符串设置替换无关紧要：]

    '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

如果您感兴趣，还有另一件事，代码wdDoc.Application.ActiveDocument.SaveAs的作用与wdDoc.SaveAs的作用[完全相同]。