Word で新しい文書を作成する Excel スプレッドシートから差し込み印刷を生成する VBA マクロを作成しました。
ユーザー入力変数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