Sub mainProc()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
'Dim xlApp As Excel.Application
'Dim Wb As Excel.Workbook
'Dim Sht As Excel.Worksheet
Dim xlApp As Object
Dim Wb As Object
Dim sht As Object
Dim EndRow As Long
Dim Arr As Variant
Dim xlRng As Object 'Excel.Range
Dim TmpDoc As Document
Dim NewName As String
Dim NewPath As String
'Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
Set Wb = xlApp.Workbooks.Open(ActiveDocument.Path & "\附件4 党员基本信息汇总表.xls")
Set sht = Wb.Worksheets(1)
With sht
For i = 21 To 5 Step -1
If .Cells(i, 2).Value <> "" Then
EndRow = i
Exit For
End If
Next i
Set xlRng = .Range("A5:T" & EndRow)
Arr = xlRng.Value
End With
Wb.Close False
xlApp.Quit
Const TmpName As String = "采集表.doc"
For i = LBound(Arr) To UBound(Arr)
Set TmpDoc = Application.Documents.Open(ActiveDocument.Path & "\" & TmpName)
TmpDoc.Activate
'姓名
FindReplace "Name", Arr(i, 2)
'性别
If Arr(i, 5) = "男" Then
FindTrue = "nan"
FindFalse = "nv"
FindTrueAndFalse FindTrue, FindFalse
Else
FindTrue = "nv"
FindFalse = "nan"
FindTrueAndFalse FindTrue, FindFalse
End If
'民族
FindReplace "mz", Split(Arr(i, 6), " ")(1)
'身份证加框
FindText = "id"
InputText = Arr(i, 4)
FindAndInput FindText, InputText
'出生日期
bir = Format(Arr(i, 7), "yyyy/mm/dd")
FindReplace "yyy1", Split(bir, "/")(0)
FindReplace "m1", Split(bir, "/")(1)
FindReplace "d1", Split(bir, "/")(2)
'学历代码加框
FindText = "XL"
InputText = Split(Arr(i, 8), " ")(0)
FindAndInput FindText, InputText
'正式预备
If Arr(i, 9) = "正式党员" Then
FindTrue = "zs"
FindFalse = "yb"
FindTrueAndFalse FindTrue, FindFalse
Else
FindTrue = "yb"
FindFalse = "zs"
FindTrueAndFalse FindTrue, FindFalse
End If
'党支部
FindReplace "dzb", Arr(i, 3)
'加入日期
bir = Format(Arr(i, 10), "yyyy/mm/dd")
FindReplace "yyy2", Split(bir, "/")(0)
FindReplace "m2", Split(bir, "/")(1)
FindReplace "d2", Split(bir, "/")(2)
'转正日期
bir = Format(Arr(i, 11), "yyyy/mm/dd")
FindReplace "yyy3", Split(bir, "/")(0)
FindReplace "m3", Split(bir, "/")(1)
FindReplace "d3", Split(bir, "/")(2)
'工作岗位代号加框
FindText = "gzgw"
InputText = Split(Arr(i, 12), " ")(0)
FindAndInput FindText, InputText
'手机号码加框
FindText = "cell"
InputText = Arr(i, 13)
FindAndInput FindText, InputText
'区号加框
FindText = "zone"
InputText = Split(Arr(i, 14), "-")(0)
FindAndInput FindText, InputText
'固话加框
FindText = "phone"
InputText = Split(Arr(i, 14), "-")(1)
FindAndInput FindText, InputText
'家庭地址
FindReplace "adr", Arr(i, 15)
'正常停止
If Arr(i, 16) = "正常" Then
FindTrue = "zc"
FindFalse = "tz"
FindTrueAndFalse FindTrue, FindFalse
Else
FindTrue = "tz"
FindFalse = "zc"
FindTrueAndFalse FindTrue, FindFalse
End If
'是否失联
If Arr(i, 17) = "是" Then
FindTrue = "yes1"
FindFalse = "no1"
FindTrueAndFalse FindTrue, FindFalse
Else
FindTrue = "no1"
FindFalse = "yes1"
FindTrueAndFalse FindTrue, FindFalse
End If
'失恋日期
If Arr(i, 17) = "是" Then
bir = Format(Arr(i, 18), "yyyy/mm")
FindReplace "yyy4", Split(bir, "/")(0)
FindReplace "m4", Split(bir, "/")(1)
Else
FindReplace "yyy4", ""
FindReplace "m4", ""
End If
'是否流出
If Arr(i, 19) = "是" Then
FindTrue = "yes2"
FindFalse = "no2"
FindTrueAndFalse FindTrue, FindFalse
Else
FindTrue = "no2"
FindFalse = "yes2"
FindTrueAndFalse FindTrue, FindFalse
End If
'流出省市县
If Arr(i, 19) = "是" Then
FindReplace "sheng", Split(Arr(i, 20), "-")(0)
FindReplace "shi", Split(Arr(i, 20), "-")(1)
FindReplace "xian", Split(Arr(i, 20), "-")(2)
Else
FindReplace "sheng", ""
FindReplace "shi", ""
FindReplace "xian", ""
End If
NewName = Arr(i, 2) & "-" & TmpName
NewPath = ActiveDocument.Path & "\批量生成文件\" & NewName
On Error Resume Next
Kill NewPath
On Error GoTo 0
TmpDoc.SaveAs2 NewPath
TmpDoc.Close
Next i
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll
End Sub
Sub FindTrueAndFalse(ByVal FindTrue As String, ByVal FindFalse As String)
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindTrue
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne
Selection.InsertSymbol Font:="Wingdings 2", CharacterNumber:=-4014, Unicode:=True
End With
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindFalse
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne
Selection.InsertSymbol Font:="宋体", CharacterNumber:=9633, Unicode:=True
End With
End Sub
Public Sub FindAndInput(ByVal FindText As String, ByVal InputText As String)
Dim Rng As Range
Dim RngStart As Long, RngEnd As Long
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne
RngStart = Selection.Start
For i = 1 To Len(InputText)
Selection.Collapse wdCollapseEnd
Selection.Range.ModifyEnclosure Style:=wdEncloseStyleSmall, Symbol:= _
wdEnclosureSquare, EnclosedText:=Mid(InputText, i, 1)
Selection.MoveRight wdCharacter, 1
Next i
RngEnd = Selection.Start
Set Rng = ActiveDocument.Range(RngStart, RngEnd)
SetFont Rng
End With
Set Rng = Nothing
End Sub
Public Sub SetFont(ByVal Rng As Range)
With Rng.Font
.Name = "黑体"
.Size = 14
End With
End Sub
Public Sub FindReplace(ByVal FindText As String, ByVal RepText As String)
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
.Replacement.Text = RepText
.Forward = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne
End With
End Sub
