20170714xlVba multiple workbooks to multiple Word document tables

Public Sub samefoldergather () application.screenupdating = False Application.DisplayAlerts = False application.ca Lculation = xlcalculationmanual Application.statusbar = ">>>>> program is transforming, please be patient >>>>>" on E Rror 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 newfold Er As String Dim NewFile As String Dim NewPath As String ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>> Set Wb = Application.thisworkbook ' Workbook level set Sht = W B.worksheets ("Summary") Sht.UsedRange.Offset (1). Clear FolderPath = wb.path & "\excel table \" Modelpath = Wb.path & "\word template \ survey tab empty table. doc" NewFolder = Wb.path & "\word table \" ' Bind Dim Wdapp As Object Dim Wdtb As Object Dim Wddoc As Object Set Wdapp = CreateObject ("W Ord. Application ") FileCount = 0 filename = Dir (FolderPath &" *.xls* ") do While FileName <>" "If Fil ename <> Thisworkbook.name Then FileCount = filecount + 1 NewFile = Split (FileName, ".") (0) & ". doc" NewPath = newfolder & NewFile Set openwb = Application.Workbooks.Open (folderpat H & FileName) with openwb Set Opensht = openwb.worksheets (sheet_index) with Opensht Dim ARR (1 to +) as String tx =. Range ("A2"). Text arr (1) = replace (Split (TX, "zone") (0), "", "") arr (2) = replace (Split (TX, " Zone ") (1)," community ") (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 (+) = Replace (Split (TX, "Fill Date") (0), ":") (1), "", "") arr (+) = Repla CE (Split (TX, "Fill Date:") (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) ' name. Cell (1, 4). Range.Text = ARR (4) ' address. Cell (2, 2). Range.Text = ARR (5) ' sex. Cell (2, 4). Range.Text = ARR (6) ' was born. Cell (2, 6). Range.Text = ARR (7) ' age. Cell (3, 2). Range.Text = ARR (8) ' phone. Cell (3, 4). Range.Text = ARR (9) ' fixed. Cell (4, 2). Range.Text = ARR (10) ' Children's cell phone. Cell (5, 2). Range.Text = ARR (11) ' home. Cell (6, 2). Range.Text = ARR (12) ' Economy. Cell (7, 2). Range.Text = ARR (13) ' health. Cell (8, 2). Range.Text = ARR (14) ' Service. Cell (9, 2). Range.Text = ARR (15) ' Service time End with Wddoc.saveas NewPath wddoc.sa ve Wddoc.close End with. Close False End with end If FileName = Dir Loop wdapp.quit ' >>>> >>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>> usedtime = VBA.    Timer-starttime MsgBox "Time-consuming:" & Format (Usedtime, "0.000 seconds"), vbOKOnly, "Nextseven Excel Studio qq laughing and joking" errorexit: Set Wb = Nothing Set Sht = Nothing Set openwb = Nothing Set Opensht = Nothing set Rng = Nothing Set wdapp = Nothing Set wddoc = no set wdtb = Nothing application.screenup Dating = True Application.DisplayAlerts = True application.calculation = xlcalculationautomatic Application.statu SBar = False Exit Sub ' >>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>errhandler : If err.number <> 0 then MsgBox err.description & "! ", vbcritical," Nextseven Excel Studio qq laughing and joking "' Debug.Print Err.Description err.clear Resume Errorexi T End IfEnd Sub

　　

20170714xlVba multiple workbooks to multiple Word document tables