unction Test() '使用双字典 SearchPath = FolderDialog("请选择文件夹") If SearchPath = "" Then Exit Function End If WordName = SplitPath(CStr(SearchPath), 1) Dim sFile As Object, fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Set logFile = fso.CreateTextFile(SearchPath & WordName & "日志.txt", True) Dim MyWord As Word.Application Set MyWord = New Word.Application MyWord.Application.ScreenUpdating = False MyWord.Application.Visible = True MyWord.Application.DisplayAlerts = wdAlertsNone Set myDoc = MyWord.Documents.Add With MyWord.ActiveDocument.PageSetup .Orientation = wdOrientLandscape '纸张方向横向 End With Dim CGType() As String '动态数组 ReDim Preserve CGType(7) CGType(0) = "控制点" CGType(1) = "界址点" CGType(2) = "界址边长" CGType(3) = "房角点" CGType(4) = "房屋边长" CGType(5) = "房屋面积" CGType(6) = "巡查" Dim ExcelApp As Object If Tasks.Exists("Microsoft Excel") = True Then Tasks("Microsoft Excel").Close Set ExcelApp = CreateObject("Excel.Application") Dim wkBook As Object '代表excelworkbook(也就是excel工作簿文件 .xls .xlsx) Dim wkSheet As Object '代表excel的工作页 ExcelApp.Application.EnableEvents = False '禁止宏等提示的运行 ExcelApp.Application.DisplayAlerts = False ExcelApp.Application.CutCopyMode = False Dim DicList, FileList, CunDic, I, FileName(), FilePath() Dim excelPath As String Set DicList = CreateObject("Scripting.Dictionary") Set FileList = CreateObject("Scripting.Dictionary") DicList.Add SearchPath, "" '初始化目录 '**************遍历一级目录 获取路径和村名******************* Do While I < DicList.Count Key = DicList.keys '本次要遍历的目录 NowDic = Dir(Key(I), vbDirectory) '开始查找 Do While NowDic <> "" If (NowDic <> ".") And (NowDic <> "..") Then If (GetAttr(Key(I) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录,则添加 If Not DicList.Exists(Key(I) & NowDic & "\") Then DicList.Add Key(I) & NowDic & "\", NowDic End If End If End If NowDic = Dir() '再找 Loop Exit Do Loop '**************************************************** '********************获取村所对应的文件夹和子文件夹******************************** Set CunDic = CreateObject("Scripting.Dictionary") k = DicList.keys v = DicList.Items For I = 0 To DicList.Count - 1 If Not v(I) = "" Then CunMin = v(I) '加入村名 放在文件字典里 If Not FileList.Exists(CunMin) Then FileList.Add CunMin, "" End If 'FileList.RemoveAll '*********************遍历村名下所有的文件夹***************************** CunDic.RemoveAll CunDic.Add k(I), "" J = 0 Do While J < CunDic.Count Key = CunDic.keys '本次要遍历的目录 NowDic = Dir(Key(J), vbDirectory) Do While NowDic <> "" If (NowDic <> ".") And (NowDic <> "..") Then If (GetAttr(Key(J) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录,则添加 If Not CunDic.Exists(Key(J) & NowDic & "\") Then CunDic.Add Key(J) & NowDic & "\", "" End If End If End If NowDic = Dir() '再找 Loop J = J + 1 Loop '*************************************************** '******************************在村名下对应的所有目录下搜索XLS文件******************************* For Each Key In CunDic.keys '查找所有目录中的控制点文件 For m = 0 To UBound(CGType) - 1 If m <= UBound(CGType) - 2 Then NowFile = Dir(Key & "*" & CGType(m) & "*.xls") Else NowFile = Dir(Key & "*" & CGType(m) & "*.docx") End If Do While NowFile <> "" If Not FileList.Exists(CunMin) Then FileList.Add CunMin, Key & NowFile 'FileList.Key=文件名,FileList.Item=目录 Else If FileList.Item(CunMin) = "" Then FileList(CunMin) = Key & NowFile Else FileList.Item(CunMin) = FileList.Item(CunMin) & "@" & Key & NowFile End If 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 = Split(FileList(element), "@") '**********记录日志 7文件是否缺少文件****************************** For x = 0 To UBound(CGType) - 1 boolFind = False For y = 0 To UBound(excelPathArray) excelPath = excelPathArray(y) If InStr(excelPath, CGType(x)) > 0 Then boolFind = True Exit For End If Next If Not boolFind Then logFile.WriteLine (element & "缺少" & CGType(x) & "成果") 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 = ExcelApp.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:" & excelrowcolumn) 'rn.Copy MyWord.Activate With MyWord If n = 0 Then MyWord.Application.Selection.InsertBefore Text:=element MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel1 MyWord.Application.Selection.EndKey Unit:=wdLine, Extend:=wdMove End If wkSheet.Range("A1:" & excelrowcolumn).Copy 'myDoc.Paragraphs(1).Range.PasteExcelTable False, False, False '粘贴为表格 MyWord.Application.Selection.PasteExcelTable False, False, False MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText If n <= UBound(excelPathArray) - 1 Then MyWord.Application.Selection.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 MyWord = 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 '*************************设置表格居中而非内容居中************************* For Each tb In myDoc.Tables tb.Rows.Alignment = wdAlignRowCenter Next '************************************************ MyWord.ActiveDocument.SaveAs FileName:=CStr(SearchPath) & WordName & ".doc" MyWord.ActiveDocument.Close MyWord.Application.ScreenUpdating = 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 = Nothing Set DicList = Nothing Set DicList = Nothing Set MyWord = Nothing MsgBox "Done" End Function 'ResultFlag=0 获取路径 'ResultFlag=1 获取文件名 'ResultFlag=2 获取扩展名 Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String Dim SplitPos As Integer, DotPos As Integer SplitPos = InStrRev(FullPath, "\") DotPos = InStrRev(FullPath, ".") Select Case ResultFlag Case 0 SplitPath = Left(FullPath, SplitPos - 1) Case 1 If DotPos = 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 DotPos = 0 Then DotPos = Len(FullPath) SplitPath = Mid(FullPath, DotPos + 1) Case Else Err.Raise vbObjectError + 1, "SplitPath Function", "无效参数!" End Select End Function Function FolderDialog(strTitle As String) As String '获取选择文件夹对话框的目录 Set objShell = CreateObject("Shell.Application") Set objDialog = objShell.BrowseForFolder(0, strTitle, 0, 0) If Not objDialog Is Nothing Then If Right(objDialog.self.Path, 1) = "\\" Then FolderDialog = objDialog.self.Path Else FolderDialog = objDialog.self.Path & "\" End If Else FolderDialog = "" MsgBox "没有选择文件夹" End If Set objDialog = Nothing Set objShell = Nothing End Function '***************************************************************************** '将Excel中列数转换为列名(如27列--->AA列) '参数:var 列数 '返回:列名 string '***************************************************************************** Public Function ChgNumToABC(ByVal var As Integer) As String Dim res As String Dim remainder As Integer '余数 Dim quotient As Integer '商 remainder = var Mod 26 If remainder = 0 Then var = var - 26 remainder = 26 End If quotient = var \ 26 If quotient <> 0 Then res = ChgNumToABC(quotient) End If ChgNumToABC = res & Chr(remainder + 65 - 1) End Function Function zhzm(num As Long) As String Dim inum As Long Dim imod As Long Application.Volatile Do While num inum = IIf(num Mod 26 = 0, num \ 26 - 1, num \ 26) imod = IIf(num Mod 26 = 0, 26, num Mod 26) zhzm = Chr(64 + imod) & zhzm num = inum Loop End Function
来源:https://www.cnblogs.com/514687800/p/9023494.html