0

我制作了一个 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
4

1 回答 1

0

我没有检查代码的其余部分,但如果您的问题仅仅是代码底部的查找和替换,那么以下应该可以完成工作(从字符串设置替换应该无关紧要):

    '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

于 2013-01-21T12:17:46.013 回答