|
|
Option Explicit
Sub TEST()
Dim dic(1) As New Dictionary, ar, br, cr, i&, j&, n&, vKey
Dim wdApp As Word.Application, wdDoc As Word.Document, strFileName$, strPath$
strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "学员手册（模板）.docx"
If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
Application.ScreenUpdating = False
With Sheets(2).[A1].CurrentRegion
ar = .Value
br = .Columns("B:D").Value
For i = 2 To UBound(ar)
dic(0)(ar(i, 1)) = Array(Join(Application.Index(br, i)), ar(i, 5), ar(i, 6))
Next i
End With
ar = Sheets(1).[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
dic(1)(ar(i, 2)) = dic(1)(ar(i, 2)) & " " & i
Next i
For Each vKey In dic(1).Keys
cr = Split(dic(1)(vKey))
ReDim br(1 To UBound(cr), 1 To 4)
For i = 1 To UBound(cr)
For j = 1 To UBound(br, 2)
br(i, j) = ar(cr(i), j + 2)
Next j
Next i
dic(1)(vKey) = br
Next
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set wdApp = New Word.Application
'wdApp.Visible = True
End If
br = Array("第x组（x人）", "联络员：", "分组学习地点：", "就餐地点：")
With wdApp
Set wdDoc = .Documents.Add
For Each vKey In dic(1).Keys
n = n + 1
cr = dic(1)(vKey)
With .Documents.Open(strFileName)
With .Content.Find
.Text = br(0)
.Forward = True
.Execute
If .Found = True Then
.Parent.Select
With wdApp.Selection
.Range.Text = "第" & vKey & "组（" & UBound(cr) & "人）"
'.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End If
End With
For i = 1 To UBound(br)
With .Content.Find
.Text = br(i)
.Forward = True
.Execute
If .Found = True Then
.Parent.Select
With wdApp.Selection
.EndKey unit:=wdLine, Extend:=wdExtend
If i = UBound(br) Then
.Range.Text = br(i) & dic(0)(vKey)(i - 1)
Else
.Range.Text = br(i) & dic(0)(vKey)(i - 1) & vbCr
End If
'.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End If
End With
Next i
With .Tables(1)
For i = 1 To UBound(cr) - 1
.Rows.Add
Next i
For i = 1 To UBound(cr)
For j = 1 To UBound(cr, 2)
.Cell(i + 1, j).Range.Text = cr(i, j)
Next j
Next i
End With
.Content.Copy
.Close False
End With
With .Selection
If n = 1 Then
.EndKey unit:=wdLine, Extend:=wdExtend
Else
.InsertBreak 7
.EndKey unit:=wdLine, Extend:=wdExtend
End If
.Paste
End With
Next
With wdDoc
.SaveAs strPath & "分组名单"
.Close
End With
End With
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
评分
-
1
查看全部评分
-
|
楼主: 路人，甲。
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-3 22:25
楼主