通过VBA宏合并Excel工作表

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

1、合并Excel文件

打开一个空Excel文件,Alt+F11,插入一个模块,开始写代码:

vbnet 复制代码
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

这段代码的作用:它首先打开一个文件选择框,你可以选择一个或多个文件,然后把这些文件里的所有Sheet合并到当前这个工作簿里来,有重名的Sheet会自动在后面加数字。

2、合并一个EXCEL多个sheet的内容到一个汇总sheet

同上,再添加一个模块吧,代码如下:

vbscript 复制代码
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

这段代码的作用:它会新建一个叫做"汇总"的工作表,然后把当前工作簿里的所有Sheet里有数据的内容都复制到"汇总"表里。提示:如果数据表里的内容没有表头的话需要把StartRow = 2改成StartRow = 1。

相关推荐
葡萄城技术团队1 天前
从100秒到10秒的性能优化,你真的掌握 Excel 的使用技巧了吗?
excel
QQ3596773453 天前
ArcGIS Pro实现基于 Excel 表格批量创建标准地理数据库(GDB)——高效数据库建库解决方案
数据库·arcgis·excel
星空的资源小屋4 天前
Digital Clock 4,一款免费的个性化桌面数字时钟
stm32·单片机·嵌入式硬件·电脑·excel
揭老师高效办公4 天前
在Excel和WPS表格中批量删除数据区域的批注
excel·wps表格
我是zxb4 天前
EasyExcel:快速读写Excel的工具类
数据库·oracle·excel
辣香牛肉面4 天前
[Windows] 搜索文本2.6.2(从word、wps、excel、pdf和txt文件中查找文本的工具)
word·excel·wps·搜索文本
ljf88385 天前
Java导出复杂excel,自定义excel导出
java·开发语言·excel
tebukaopu1485 天前
json文件转excel
json·excel
shizidushu5 天前
How to work with merged cells in Excel with `openpyxl` in Python?
python·microsoft·excel·openpyxl
会飞的小菠菜5 天前
把多个 PPT 合并在一起,三步告别复制粘贴
powerpoint·合并·ppt·批量·幻灯片