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

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)