vba 从用户输入变量中查找和替换单独的 Word 文档中的文本
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/14318973/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
提示：将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间：2020-09-11 19:10:16 来源:igfitidea点击:
Find and replace text in a separate Word document from a user input variable
提问by Tom McDonald
I made a VBA macro that generates a MailMerge from an Excel spreadsheet creating the new document in Word.
我制作了一个 VBA 宏，它从在 Word 中创建新文档的 Excel 电子表格生成 MailMerge。
I need to run a Find and Replace on a particular phrase ('ANTHXXXX') in the Word document with the user input variable InputtedModuleCode.
我需要运行一个查找和与用户输入变量的Word文档中的特定短语（“ANTHXXXX”）更换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.
...距脚本底部约 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
回答by CuberChase
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.SaveAsdoes exactlythe same thing as wdDoc.SaveAs.
还有一件事，如果你有兴趣，代码wdDoc.Application.ActiveDocument.SaveAs不正是同样的事情wdDoc.SaveAs。
