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 = http://www.mamicode.com/Arr"本次耗时：" & 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