一键批量拆分Excel工作表【模板下载】

从合并相同内容的单元格到合并多个工作表直至批量合并多个Excel工作簿，所有的操作只需要一键！

专辑如下，也可以在表哥公众号底部菜单栏左侧【来份干货】找到。

有读者给表哥留言既然有合并工作簿工作表的工具，怎么能没有一键拆分的工具呢？

读者朋友的提问其实也让我们看到了大家平时工作上的需求，Excel表哥公众号也乐于帮助读者解决Excel应用方面的任何问题。

因此我们今天特意制作这篇一键拆分工作表，生成若干新表或者工作簿的方法分享给大家。

今天的分享给大家展示在日常工作中VBA是如何成百上千倍地帮忙提高我们的工作效率的！

01

案例分享

以一位读者朋友的提问为案例。

我们希望将信息总表每一行的汇总信息按照基本信息表中给定的格式拆分为不同的工作表/工作簿。

如果不借助VBA，常规的做法一般是不断的在两个工作表或者工作簿之间来回复制粘贴。

想象一下如果这个汇总表有上百行数据，这种重复的操作将会非常无趣且容易出错。

02

VBA一键操作

针对这种重复性的操作，其实Excel中内置的VBA非常有帮助。

首先来看下一键拆分的效率有多高：

针对案例中的拆分需求 以6行数据为例

拆分为6个工作表用时1s，拆分为6个独立的工作簿，用时5s。

相比较人工复制粘贴，效率提高岂止上千倍！

03

代码解析

大家不用把VBA想象的太复杂，整个程序不是很长，也不用自己每一行都手敲代码。

通过录制宏并稍作修改就可以完成这些基本操作，当然前提是还是需要稍微懂一点点VBA常识。

详细代码如下，具体语句作用参考代码注释。

Sub 工作表拆分() Dim Wb, Sht, msht, NewSht, rng Set Wb = Application.ThisWorkbook Set Sht = Wb.Worksheets('信息总表') Set msht = Wb.Worksheets('基本信息') With Sht endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row If endrow <= 1 Then Exit Sub Set rng = .Range('A2:O' & endrow) arr = rng.Value End With Tempelate = '工作簿拆分工具' sel = Val(Application.InputBox('选择拆分至工作表还是工作簿 ' & vbNewLine & vbNewLine & '1：工作表 2: 工作簿', Title:=Tempelate, Default:=1, Type:=1)) If sel = 0 Then Exit Sub    timenow = Time For i = LBound(arr) To UBound(arr)        msht.Copy After:=Wb.Worksheets(Wb.Worksheets.Count) '基本信息表复制至新表 Set NewSht = Wb.Worksheets(Wb.Worksheets.Count) With NewSht            newname = arr(i, 3) '以第三列的姓名来给新表格命名 Application.DisplayAlerts = False            Application.ScreenUpdating = False                        On Error Resume Next  '删除工作表可能会出现错误，此处忽略错误继续执行          Wb.Worksheets(newname).Delete '删除工作表            '下面是每个子表格的填写操作 .Name = newname            .Range('B2').Value = arr(i, 3) '小表B2单元格的内容=大表的第3列的姓名，以此类推            '.... '以此类推，需根据自己的需要调整修改              .Range('B6').Value = arr(i, 9)                                  If sel = 2 Then '另存为新工作簿 ActiveSheet.Select ActiveSheet.Move ChDir ThisWorkbook.Path ActiveWorkbook.SaveAs Filename:=arr(i, 3) & '.xlsx', _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWorkbook.Close End If        End With    Next i     Windows(Wb.Name).Activate Wb.Sheets('信息总表').Select Application.ScreenUpdating = True Set Wb = Nothing Set Sht = Nothing Set msht = Nothing Set NewSht = Nothing    Set rng = Nothing    timeuse = Round((Time - timenow) * 24 * 60 * 60, 2) If sel = 2 Then MsgBox 'Done!' & vbNewLine & '拆分的工作簿位于当前路径！' & vbNewLine & '总共用时 ' & timeuse & 's', Title:=Tempelate Else        MsgBox 'Done!' & vbNewLine & '拆分的内容位于当前工作簿！' & vbNewLine & '总共用时 ' & timeuse & 's', Title:=Tempelate    End IfEnd Sub

▲左右滑动查看完整代码

将这段sub程序宏代码指定至一个按键，之后如动图演示，只需点击此按键就可以一键完成工作表的拆分。

而且还可以根据自己的需要选择拆分为新的工作表或者工作簿，十分人性化。

因为每个人的表格设计的都不一样，子表格的填表这段代码就留给读者自己来修改吧。