常用功能加载宏——多个工作簿合并到一个工作簿

对于做管理工作的，收集表格这种工作应该会经常有，设计一个表格模板，发给各个有关单位去填写，收集起来后再合并到一起。

如果表格太多，一个一个的手动操作肯定很麻烦，设计一个VBA程序来合并就非常方便了：

首先在customUI.xml中增加代码：

代码语言：javascript复制

     <menu id="rbmenuMergeSplit" label="合并拆分&#13;" size="large" imageMso="ReviewCombineRevisions">
      <button id="rbbtnMergeWb" label="合并工作簿" onAction="rbbtnMergeWb" imageMso="FileSaveAsExcelXlsx" />
     </menu>

回调函数：

代码语言：javascript复制

Sub rbbtnMergeWb(control As IRibbonControl)
    Call MShtWk.MergeWb
End Sub

函数实现：

代码语言：javascript复制

Sub MergeWb()
    Dim strDir As String
    Dim RetDirs() As String, RetFiles() As String
    '选择要查找的文件夹
    strDir = GetFolderPath()
    If VBA.Len(strDir) = 0 Then Exit Sub
    '遍历获取文件
    If ScanDir(strDir, RetDirs, RetFiles) = -1 Then Exit Sub
    
    '记录活动工作簿
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
     '关闭屏幕更新，提高速度
    Application.ScreenUpdating = False
    
    Dim i As Long
    Dim flag As Boolean
    Dim tmp As Workbook
    For i = 0 To UBound(RetFiles)
        '过滤活动工作簿和打开的临时文件
        If RetFiles(i) <> wb.FullName And VBA.InStr(RetFiles(i), "~$") = 0 Then
            flag = False
            '避免用Or将多个判断连接在一起，因为那样会每一个判断都执行
            If VBA.InStr(RetFiles(i), ".xls") Then
                flag = True
            ElseIf VBA.InStr(RetFiles(i), ".xls") Then
                flag = True
            ElseIf VBA.InStr(RetFiles(i), ".xlsx") Then
                flag = True
            ElseIf VBA.InStr(RetFiles(i), ".xlsm") Then
                flag = True
            End If
            
            If flag Then
                Set tmp = Workbooks.Open(RetFiles(i), False)
                '复制每一个Sheet数据，这里可以根据自己实际需要来复制
                tmp.Worksheets.Copy After:=wb.Worksheets(wb.Worksheets.Count)
                
                tmp.Close False
            End If
        
        End If
    Next
    
    Application.ScreenUpdating = True
    
    Set wb = Nothing
    Erase RetDirs, RetFiles
End Sub

xml vba 表格 程序 设计

0 人点赞