20170714xlVba multiple workbooks to multiple Word document tables

Source: Internet
Author: User

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

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.