excel文件或sheet表的vba合并

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

         我们在工作中经常会用到的把几个Excel文件合并到一个，或者是把一个Excel文件里的所有Sheet合并到一个Sheet来进行统计。下面分别提供用vba宏来解决这两个问题的方法。

        方法：打开一个空Excel文件，Alt+F11，插入一个模块，开始写代码：
1、文件合并
Sub MergeWorkbooks()
    Dim FileSet
    Dim i As Integer
   
    On Error GoTo 0
    Application.ScreenUpdating = False
    FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", MultiSelect:=True, Title:="选择要合并的文件")
   
    If TypeName(FileSet) = "Boolean" Then
        GoTo ExitSub
    End If
   
    For Each Filename In FileSet
        Workbooks.Open Filename
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Next
   
ExitSub:
    Application.ScreenUpdating = True
   
End Sub

2、sheet表合并
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
Sub MergeSheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    '新建一个"汇总"工作表
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("汇总").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "汇总"
    '开始复制的行号，忽略表头，无表头请设置成1
    StartRow = 2
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
            If shLast > 0 And shLast >= StartRow Then
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "内容太多放不下啦！"
                    GoTo ExitSub
                End If
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If
        End If
    Next
ExitSub:
    Application.GoTo DestSh.Cells(1)
    DestSh.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏2 回帖

关键词：EXCEL sheet xcel exce SHE excel False Excel Error

学习学习O(∩_∩)O哈！