Word VBA (bulk copy of Excel tables and Word tables into Word)

Source: Internet
Author: User
Tags spl

Unction Test () ' uses a double dictionary SearchPath = Folderdialog ("Select Folder") If SearchPath = "then Exit Function End I F wordname = Splitpath (CStr (SearchPath), 1) Dim SFile as Object, FSO as Object Set FSO = CreateObject ("Sc Ripting. FileSystemObject ") Set LogFile = fso. CreateTextFile (SearchPath & wordname & "log. txt", True) Dim MyWord as Word.Application Set MyWord = New W Ord. Application MyWord.Application.ScreenUpdating = False MyWord.Application.Visible = True MyWord.Application.Di Splayalerts = wdAlertsNone Set MyDoc = MyWord.Documents.Add with MyWord.ActiveDocument.PageSetup. Orientation = wdOrientLandscape ' paper direction transverse End with Dim cgtype () as String ' dynamic array ReDim Preserve Cgtype (7 ) Cgtype (0) = "Control Point" cgtype (1) = "Boundary Points" cgtype (2) = "Boundary side Length" cgtype (3) = "Corner Point" cgtype (4) = "House side Length" Cgtype (5) = "House Area" Cgtype (6) = "Patrol" Dim Excelapp as Object If tasks.exists ("Microsoft exceL ") = True then Tasks (" Microsoft Excel "). Close Set excelapp = CreateObject ("Excel.Application") Dim Wkbook as Object ' represents ExcelWorkbook (that is, Excel workbook file. xls. xlsx) Dim Wksheet as Object ' represents Excel's work page ExcelApp.Application.EnableEvents = False ' suppress macros and other prompts to run Excelapp.applicati On.  DisplayAlerts = False ExcelApp.Application.CutCopyMode = False Dim diclist, FileList, Cundic, I, FileName (), FilePath () Dim Excelpath as String set diclist = CreateObject ("Scripting.Dictionary") Set FileList = Createobjec T ("Scripting.Dictionary") Diclist.add SearchPath, "' Initialize directory ' ************** traverse first-level directory get path and village name ******************        * Do While I < diclist.count Key = Diclist.keys ' This minor traversal of the directory nowdic = Dir (Key (I), vbdirectory) ' Start lookup Do While Nowdic <> "" If (Nowdic <> ".") and (Nowdic <> "...") Then if (GetAttr (keys (I) & Nowdic) and vbdirectory) = Vbdirectory Then ' Find subdirectories, add if NotDiclist.exists (Key (i) & nowdic & "\") then Diclist.add Key (i) & nowdic & "\", Nowdi C End If End If Nowdic = Dir () ' Look for Loop Exit Do Loop ' **************************************************** ' ******************** get the corresponding folder and sub files for the village Clamp ******************************** Set cundic = CreateObject ("Scripting.Dictionary") K = Diclist.keys v = DicList.            Items for I = 0 to diclist.count-1 If not V (i) = "and then Cunmin = V (i) ' Join the village name in the file dictionary If not filelist.exists (cunmin) then Filelist.add cunmin, "End If" FileList.            RemoveAll ' ********************* traverse the village name all folders ***************************** Cundic.removeall                Cundic.add K (I), "" j = 0 Do While J < cundic.count Key = Cundic.keys ' This secondary traversal of the directory Nowdic = DIR (Key (J), vbdirectory) do while Nowdic <> "" If (Nowdic <> ".") and (Nowdic <> "...")                            Then If (GetAttr (Keys (J) & Nowdic) and vbdirectory) = Vbdirectory Then ' Find subdirectories, add If not Cundic.exists (keys (j) & Nowdic & "\") then Cundic.add Key (j) &am P                    Nowdic & "\", "" "End If End If End if Nowdic = Dir () ' Find loop J = j + 1 Loop ' ********************** ' ****************************** search for XLS files in all directories corresponding to the village name *******************  For every Key in Cundic.keys ' Find control point files in all directories for m = 0 to UBound (Cgtype)-1 If m <= UBound (Cgtype)-2 Then Nowfile = Dir (Key & " * "&Amp Cgtype (M) & "*.xls") Else Nowfile = Dir (Key & "*" & Cgtype (M) & "*.docx") End if do and Nowfile <> "" If not FileList .                        Exists (cunmin) then Filelist.add cunmin, Key & nowfile ' filelist.key= filename, filelist.item= directory Else If filelist.item (cunmin) = "Then Fi Lelist (cunmin) = Key & Nowfile Else filelist.item (cunmin) =                        Filelist.item (cunmin) & "@" & Key & Nowfile End If    Nowfile = Dir () Loop next next End If Next ' ********************************************************************************************* FileName () = Filelist.keys FilePath () =Filelist.items for m = 0 to filelist.count-1 element = FileName (m) Excelpatharray = SPL It (FileList (Element), "@") ' ********** log 7 files are missing files ****************************** for x = 0 to UBound (cgty PE)-1 boolfind = False for y = 0 to UBound (excelpatharray) Excelpath = Excelpatharr  Ay (y) If InStr (Excelpath, Cgtype (x)) > 0 Then boolfind = True Exit  For End if Next if is Boolfind then Logfile.writeline (element & "Missing" & Cgtype (x) & "Results") End If Next ' ******************************************            For n = 0 to UBound (excelpatharray) Excelpath = Excelpatharray (n)                                extention = Splitpath (Excelpath, 2) If StrComp (extention, "xls", vbTextCompare) = 0 Then Set Wkbook= ExcelApp.Workbooks.Open (excelpath) Set wksheet = wkbook.worksheets (1) lastrowcount = Excel                App.ActiveSheet.UsedRange.Rows.Count Lastcolumncount = ExcelApp.ActiveSheet.UsedRange.Columns.Count  Lastencolumncount = CHGNUMTOABC (lastcolumncount) Excelrowcolumn = Lastencolumncount & CStr (Lastrowcount) ' Dim rng as Object ' Set rng = Wksheet.range ("A1:" & Excelrowco Lumn) ' Rn.                        Copy myword.activate with MyWord If n = 0 Then MyWord.Application.Selection.InsertBefore text:=element MYWORD.APPLICATION.SELECTION.P Aragraphformat.outlinelevel = WdOutlineLevel1 MyWord.Application.Selection.EndKey unit:=wdline, EXT End:=wdmove End If wksheet.range ("A1:" & Excelrowcolumn).                  Copy  ' Mydoc.paragraphs (1). Range.pasteexceltable false, False, false ' paste as table MyWord.Application.Selection.Past Eexceltable false, False, false MyWord.Application.Selection.ParagraphFormat.OutlineLevel = Wdoutlinele Velbodytext If n <= UBound (Excelpatharray)-1 then MyWord.Application.Select Ion.                        EndKey unit:=wdstory, Extend:=wdmove MyWord.Application.Selection.Range.InsertAfter (vbCrLf)                    ' Else ' MyWord.Application.Selection.EndKey unit:=wdstory, Extend:=wdmove End If ExcelApp.Application.Workbooks.Close End With ' Set Mywor                D = Nothing ElseIf StrComp (extention, "docx", vbTextCompare) = 0 Then Myword.activate Set Otherdoc = MyWord.Documents.Open (excelpath) otherdoc.activate myword.application. Selection.wholestory MyWord.Application.Selection.Copy mydoc.activate MyWord.                 Application.Selection.EndKey Unit:=wdline, Extend:=wdmove MyWord.Application.Selection.Paste        MyWord.Application.Selection.InsertBreak (wdpagebreak) otherdoc.close End If    Next Next ' ************************* set table centered instead of content centered ************************* for each TB in Mydoc.tables Tb. rows.alignment = wdAlignRowCenter Next ' ************************************************ MyWord.ActiveDocument.Sa Veas filename:=cstr (SearchPath) & Wordname & ". doc" MyWord.ActiveDocument.Close MYWORD.APPLICATION.SCREENUPD    ating = Ture myword.quit savechanges:=wddonotsavechanges ExcelApp.Application.CutCopyMode = False logfile.close Set logFile = Nothing Set fso = Nothing ExcelApp.Application.Quit Set cundic = Nothing Set FileList = Nothin G Set diclist = NOthing Set diclist = Nothing Set MyWord = Nothing MsgBox "Done" End Function ' resultflag=0 get path ' Resultfla g=1 get filename ' resultflag=2 get extension public Function Splitpath (FullPath As String, Resultflag as Integer) as String Dim SPL    ITPOs As Integer, dotpos as Integer splitpos = InStrRev (FullPath, "\") Dotpos = InStrRev (FullPath, ".") Select case Resultflag case 0 Splitpath = left (FullPath, SplitPos-1) Case 1 If dotpo                     s = 0 Then If right (FullPath, 1) = "\" Then FullPath = Left (FullPath, Len (FullPath)-1)            Splitpos = InStrRev (FullPath, "\") End If Dotpos = Len (FullPath) + 1 End If Splitpath = Mid (FullPath, Splitpos + 1, dotpos-splitpos-1) Case 2 If Dotpo s = 0 Then Dotpos = Len (FullPath) Splitpath = Mid (FullPath, Dotpos + 1) case Else Err.Raise V Bobjecterror + 1, "Splitpath Function "," Invalid parameter! " End selectend functionfunction Folderdialog (strtitle as String) As String gets the directory of the Select Folder dialog box Set Objshell = CreateObject    ("Shell.Application") Set objdialog = Objshell.browseforfolder (0, strtitle, 0, 0) if not objdialog are nothing and then If right (objdialog. Self. Path, 1) = "\ \" Then Folderdialog = ObjDialog.self.Path Else Folderdialog = objDialog.self.Pa    Th & "\" End If Else folderdialog = "MsgBox" No folder selected "End If Set objdialog = Nothing Set Objshell = nothingend Function ' ***************************************************************************** ' Convert columns in Excel to column names (such as 27 columns--->aa column) ' Parameters: var columns ' return: Column name string ' ********************************************************** Public Function chgnumtoabc (ByVal var as Integer) As String Dim res As String Dim remainder as in Teger ' remainder Dim quotient as Integer ' quotient remainder = var Mod If remainder = 0 then var = var -remainder = + End if quotient = var \ if quotient <> 0 Then res = CHGNUMTOABC (quoti ENT) End If CHGNUMTOABC = res & Chr (remainder + 65-1) end functionfunction zhzm (num as Long) as String Dim I Num as Long Dim imod as long application.volatile do while num inum = IIf (num Mod = 0, num \ 26-1, nu m \ imod = IIf (num mod 0, num mod) Zhzm = Chr (+ imod) & zhzm num = Inum Loo PEnd Function

  

Word VBA (bulk copy of Excel tables and Word tables into Word)

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.