20170612xlVBA含方框文档填表

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