20170714xlVba多个工作簿转多个Word文档表格

Public Sub SameFolderGather()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>程序正在转化，请耐心等候>>>>>"

    'On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim Opensht As Worksheet
    Const SHEET_INDEX = 1
    Const OFFSET_ROW As Long = 1

    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long

    Dim ModelPath As String
    Dim NewFolder As String
    Dim NewFile As String
    Dim NewPath As String

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook    '工作簿级别
    Set Sht = Wb.Worksheets("汇总")
    Sht.UsedRange.Offset(1).Clear
    FolderPath = Wb.Path & "\Excel表格\"
    ModelPath = Wb.Path & "\Word模板\调查统计表空表.doc"

    NewFolder = Wb.Path & "\Word表格\"
    '绑定
    Dim wdApp As Object
    Dim wdTb As Object
    Dim wdDoc As Object
    Set wdApp = CreateObject("Word.Application")

    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            FileCount = FileCount + 1

            NewFile = Split(FileName, ".")(0) & ".doc"
            NewPath = NewFolder & NewFile

            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            With OpenWb
                Set Opensht = OpenWb.Worksheets(SHEET_INDEX)

                With Opensht
                    Dim Arr(1 To 17) As String
                    tx = .Range("A2").Text
                    Arr(1) = Replace(Split(tx, "区")(0), " ", "")
                    Arr(2) = Replace(Split(Split(tx, "区")(1), "社")(0), " ", "")
                    Arr(3) = .Range("B3").Value
                    Arr(4) = .Range("D3").Value
                    Arr(5) = .Range("B4").Value
                    Arr(6) = .Range("D4").Value
                    Arr(7) = .Range("F4").Value
                    Arr(8) = .Range("B5").Value
                    Arr(9) = .Range("E5").Value
                    Arr(10) = .Range("B6").Value
                    Arr(11) = .Range("B7").Value
                    Arr(12) = .Range("B8").Value
                    Arr(13) = .Range("B9").Value
                    Arr(14) = .Range("B10").Value
                    Arr(15) = .Range("B11").Value
                    tx = .Range("A14").Text
                    Arr(16) = Replace(Split(Split(tx, "填表日期")(0), "：")(1), " ", "")
                    Arr(17) = Replace(Split(tx, "填表日期：")(1), " ", "")

                    Sht.Cells(FileCount + 1, 1).Resize(1, 17).Value = Arr

                    Set wdDoc = wdApp.Documents.Open(ModelPath)
                    Set wdTb = wdDoc.Tables(1)
                    With wdTb
                        .Cell(1, 2).Range.Text = Arr(3)  '姓名
                        .Cell(1, 4).Range.Text = Arr(4)     '住址
                        .Cell(2, 2).Range.Text = Arr(5)     '性别
                        .Cell(2, 4).Range.Text = Arr(6)     '出生
                        .Cell(2, 6).Range.Text = Arr(7)     '年龄
                        .Cell(3, 2).Range.Text = Arr(8)     '手机
                        .Cell(3, 4).Range.Text = Arr(9)     '固话
                        .Cell(4, 2).Range.Text = Arr(10)     '子女手机
                        .Cell(5, 2).Range.Text = Arr(11)     '家庭
                        .Cell(6, 2).Range.Text = Arr(12)     '经济
                        .Cell(7, 2).Range.Text = Arr(13)     '健康
                        .Cell(8, 2).Range.Text = Arr(14)     '服务
                        .Cell(9, 2).Range.Text = Arr(15)     '服务时间
                    End With
                  wdDoc.SaveAs NewPath
                  wdDoc.Save
                  wdDoc.Close

                End With

                .Close False
            End With
        End If
        FileName = Dir
    Loop

    wdApp.Quit

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio QQ嘻嘻哈哈"

ErrorExit:
    Set Wb = Nothing
    Set Sht = Nothing
    Set OpenWb = Nothing
    Set Opensht = Nothing
    Set Rng = Nothing

    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set wdTb = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio QQ嘻嘻哈哈"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub