excel表格内容拆分_一键批量拆分Excel工作表【模板下载】

今年5月份我们在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 If
End Sub

▲左右滑动查看完整代码

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

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

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

大家也可以下载模板进行对照练习，读者朋友可关注公众号并在下方的留言区获取后台下载关键词哦~

专辑查看方式

注：本公众号所载原创文章均为作者辛苦创作，转载请联系作者并标明出处。

处处留心皆学问，建议大家可以将这篇推文收藏，以备不时之需。

---

原文及下载地址：

一键批量拆分Excel工作表【模板下载】​mp.weixin.qq.com

你点的每个"赞"我都认真当成了喜欢▼