黄河交通学院-学生学习状态分析及指导表(快速填写方法-word-邮件合并-拆分-重命名)

黄河交通学院学生学习状态分析及指导
（个人、单科）
第一步：制作相应的EXCEL表格，根据该WORD表格的相关内容，填写EXCEL表格。

第二步：邮件合并
1.
2.
3.找到所填写的EXCEL表格及对应的名称，点“确定”
4.把光标定位到所需添加的位置，插入域
5.所有内容都出入之后，完成并合并，选择编辑单个文档。

即完成了邮件合并，此时，所有学生的信息在同一个较大的word文档
三、拆分及重命名
找到宏，选“查看宏”——创建——把下面内容粘贴进去，在粘贴的时候注意只粘贴“红色”的字体。

Sub 拆分重命名()
'
' 拆分重命名宏
'
Dim intChoice As Integer
Dim strPath As String
Dim objWord As Object
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'if the user selects a file
If intChoice <> 0 Then
'get the path selected
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'opens the document
Set mainDoc = Documents.Open(strPath)
'MsgBox (mainDoc)
'MsgBox (TypeName(mainDoc))
'MsgBox (Documents.Count)
'MsgBox (Documents(1))
'MsgBox (TypeName(Documents(1)))
'doc = Documents(1)
mainDoc.Activate
mainDoc.Repaginate
Pages = mainDoc.BuiltInDocumentProperties(wdPropertyPages)
MsgBox ("total page" & Pages)
CurrentPage = 1
Set fso = CreateObject("Scripting.FileSystemObject")
Set regEx = CreateObject("vbscript.regexp")
'Dim regEx As New RegExp
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\d+"
End With
While CurrentPage <= Pages
Dim rgePages As Range
'MsgBox (CurrentPage)
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=CurrentPage Set rgePages = Selection.Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=CurrentPage rgePages.End = Selection.Bookmarks("\Page").Range.End
rgePages.Copy
Set NewDoc = Documents.Add
NewDoc.Activate
NewDoc.Windows(1).Selection.Paste
Set Table = NewDoc.Tables(1)
Number = regEx.Execute(Table.Cell(1, 5).Range.Text)(0).V alue
StudentName = Replace(Table.Cell(1, 3).Range.Text, Chr(13) & Chr(7), "")
Course = Replace(Table.Cell(3, 3).Range.Text, Chr(13) & Chr(7), "")
'MsgBox (Number)
'FileName = Number & "_" & StudentName & "_" & Course & ".docx"
FileName = Number & StudentName & "_" & Course & ".docx"
strNewName = fso.BuildPath(fso.GetParentFolderName(strPath), FileName)
'fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
'MsgBox (strNewName)
NewDoc.SaveAs (strNewName)
NewDoc.Close
CurrentPage = CurrentPage + 1
mainDoc.Activate
Wend
'For Each t In mainDoc.Tables
'MsgBox (t.Cell(5, 1))
't.Select()
'Next
MsgBox ("Done OK")
End If
End Sub
然后打开你所需要拆分并重命名的文件，运行即可。

在运行时，出现“total page 页数”，点确定；
出现Done OK时，即完成了拆分及重命名。

注：重命名只针对该表格，如果表格不同，只需在稍微改一下单元格就行
OFFIC版本不同稍有差别。