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