Word VBA(批量复制Excel表格和Word表格到Word中)

Function 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