楼主
0Mouse |
Q：如何运用VBA根据Excel花名册信息批量生成Word格式的退工证明单呢？
花名册信息如图1所示，退工证明单模板如图2所示，如何快速将花名册中的信息逐行填入退工证明单模板中呢？要求：每页放两张证明单。图3是批量生成的退工证明单中的一个示例。
图1：花名册信息
图2：退工证明单模板
图3：生成的退工证明单示例
A：双击打开退工证明单模板文件，按<Alt+F11>组合键，依次单击“插入”-“模块”，在显示的空白窗口内粘贴以下代码，按<F5>键，稍等片刻即可在模板文件同一文件夹下生成“Result.docx”文件，此文件即为结果文件，而模板文件不受影响。
- Sub 运用VBA根据Excel花名册信息批量生成Word格式的退工证明单()
- Dim Doc As Document, Arr, Rng As Range, i%, j%, sTxt$, mth
- Set Doc = ThisDocument
- With CreateObject("Excel.Application")
- With .workbooks.Open(Doc.Path & "\date base.xlsx")
- Arr = .activesheet.Range("A1").currentregion.Value
- .Close False
- End With
- .Quit
- End With
- Set Rng = Doc.Range(0, Doc.Range.End - 1)
- Selection.EndKey wdStory
- With CreateObject("vbscript.regexp")
- For i = 1 To UBound(Arr) - 2
- Rng.Copy
- With Selection
- .EndKey wdStory
- .Paste
- End With
- Next i
- For i = 2 To UBound(Arr)
- sTxt = Doc.Content
- For j = 12 To 1 Step -1
- .Pattern = "A" & j
- For Each mth In .Execute(sTxt)
- With Doc.Range(mth.firstindex, mth.firstindex + mth.Length)
- Select Case j
- Case 2
- .text = IIf(Arr(i, j) = "男", "R男 □女", "□男 R女")
- If i Mod 2 = 0 Then
- .Select
- Selection.MoveUp wdLine, 3
- Selection.Paragraphs.PageBreakBefore = True
- End If
- Case 4
- .text = IIf(Arr(i, j) = "全日制", "R全日制 □非全日制", "□全日制 R非全日制")
- Case 6
- .text = IIf(Arr(i, j) = "合同终止", "R合同终止 □合同解除", "□合同终止 R合同解除")
- Case 10
- .text = IIf(Arr(i, j) = "机要邮寄", "R机要邮寄 □单位自送", "□机要邮寄 R单位自送")
- Case 12
- .text = IIf(Arr(i, j) = "已交", "R已交 □未交", "□已交 R未交")
- Case Else
- If InStr("359", j) Then
- .text = Format(Arr(i, j), "yyyy 年 m 月 d 日")
- Else
- .text = Arr(i, j)
- End If
- End Select
- End With
- Next mth
- Next j
- sTxt = ""
- Next i
- .Global = True
- .Pattern = "R"
- sTxt = Doc.Content
- For Each mth In .Execute(sTxt)
- Doc.Range(mth.firstindex, mth.firstindex + 1).Font.Name = "Wingdings 2"
- Next mth
- .Pattern = " [年月日]"
- For Each mth In .Execute(sTxt)
- Doc.Range(mth.firstindex + 1, mth.firstindex + 2).Font.Underline = wdUnderlineNone
- Next mth
- ReDim Arr(1 To i - 2)
- j = 0
- .Pattern = "\d{17}(\d|X)"
- For Each mth In .Execute(sTxt)
- j = j + 1
- Arr(j) = mth.firstindex
- Next mth
- For i = UBound(Arr) To 1 Step -1
- For j = 17 To 0 Step -1
- Doc.Range(Arr(i) + j, Arr(i) + 1 + j).ModifyEnclosure wdEncloseStyleLarge, wdEnclosureSquare
- Next j
- Next i
- sTxt = ""
- End With
- Selection.EndKey wdStory
- Selection.TypeBackspace
- sTxt = Doc.Path & "\Result.docx"
- If Len(Dir(sTxt)) Then Kill sTxt
- On Error Resume Next
- Doc.SaveAs2 sTxt, wdFormatDocumentDefault
- MsgBox "任务完成！", vbInformation, "报告"
- End Sub
附件：
 批量生成退工单.rar
|
