Excel的VBA宏：查找和輸入的用戶變量

Question

我已經作出了VBA宏從Excel電子表格創建Word中的新文檔生成郵件合併更換單獨的Word文檔中的文本。我需要運行一個查找和沒有任何錯誤與用戶的Word文檔中的特定短語（「ANTHXXXX」）輸入變量InputtedModuleCode

目前VBA宏運行更換，但我不能讓它找到並替換。我已經包含下面的整個宏腳本，但是腳本的相關行是註釋下面：

「查找和替換模塊代碼

...從腳本的底部大約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。