Excel表格拆分

一、说明

此脚本支持对Excel表格中任意一列为筛选条件进行拆分，并支持两种格式（xls和xlsx）以及脏数据的导出。

二、支持范围

支持Visual Basic的各版本Excel。由于没有WPS会员，因此WPS未进行测试。

三、脚本

' Function: SplitExcel
' Version: 0.8beta
' Time: 2020-11-02
' By: SuiFenPX
' E-mail: suifenpx@qq.com

Sub SplitExcel()
    If MsgBox("是否筛选出筛选条件为空的值？" & Chr(13) & Chr(10) & "点击确定继续筛选，点击取消进行检查。", vbExclamation + vbOKCancel) = vbOK Then
        GoTo SplitFunction
    Else
        Exit Sub
    End If

SplitFunction:
    Dim OutFormat, BasePath, FolderPath, FileSysObj
    Dim RegionArray, DictionaryObject As Object, DiObjKeys, DiObjItems, i&, CriticalValue%, Rng As Range, SplitCondition%

    ' 选择数据格式，文本框方式
OutFormatFunction:
    OutFormat = "." & Application.InputBox("请输入xls或xlsx来选择数据导出格式。")
    If OutFormat = ".xls" Or OutFormat = ".xlsx" Then
        GoTo MainFunction
    Else
        MsgBox "请按提示输入正确内容！", vbExclamation
        GoTo OutFormatFunction
    End If

MainFunction:
    ' 创建拆分结果存放目录
    BasePath = ThisWorkbook.Path & Application.PathSeparator
    FolderPath = BasePath & "拆分结果"

    Set FileSysObj = CreateObject("Scripting.FileSystemObject")

    If FileSysObj.FolderExists(FolderPath) Then
        MsgBox "当前目录下存在“拆分结果”文件夹，请清理！", vbExclamation
        Exit Sub
    Else
        MkDir FolderPath
    End If

    ' 获取筛选列的列号
    SplitCondition = Application.InputBox("请输入拆分列号")

    If SplitCondition = 0 Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    RegionArray = [a1].CurrentRegion
    CriticalValue = UBound(RegionArray, 2)

    ' 定义数据字典
    Set Rng = [a1].Resize(, CriticalValue)
    Set DictionaryObject = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(RegionArray)
        If Not DictionaryObject.Exists(RegionArray(i, SplitCondition)) Then
            Set DictionaryObject(RegionArray(i, SplitCondition)) = Cells(i, 1).Resize(1, CriticalValue)
        Else
            Set DictionaryObject(RegionArray(i, SplitCondition)) = Union(DictionaryObject(RegionArray(i, SplitCondition)), Cells(i, 1).Resize(1, CriticalValue))
        End If
    Next

    ' 定义筛选条件存放变量
    DiObjKeys = DictionaryObject.Keys
    ' 定义数据行存放变量
    DiObjItems = DictionaryObject.Items

    ' 根据条件拆分表格
    For i = 0 To DictionaryObject.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            ' 获取表头
            Rng.Copy .Sheets(1).[a1]
            ' 获取数据行
            DiObjItems(i).Copy .Sheets(1).[a2]
            If DiObjKeys(i) = "" Then
                .SaveAs Filename:=ThisWorkbook.Path & "\" & "筛选条件为空的数据" & OutFormat
                .Close
            Else
                .SaveAs Filename:=ThisWorkbook.Path & "\" & "拆分结果" & "\" & DiObjKeys(i) & OutFormat
                .Close
            End If
        End With
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "处理完毕！" & Chr(13) & Chr(10) & "By:SuiFenPX", vbInformation
End Sub

四、使用方法

1. 开启Excel的开发工具套件，具体方法如下。
   首先打开一个空白的Excel表格（以Excel2016为例），然后点击 文件 按钮并在跳转页面点击 选项 按钮打开Excel选项卡。接下在 自定义功能区 列表中 主选项卡 区域勾选 开发工具 选择框，最后点击 确定 按钮即可（此方法永久开启开发工具，之后可关闭该空白表格）。

2. 打开待处理的表格，并向其中导入脚本以及创建按钮。
   首先打开待处理的表格，然后按下 ALT + F11 组合键打开Visual Basic编辑器，之后选择 插入 列表下的 模块 按钮打开编辑器页面。接下来将代码复制到编辑器内并保存，之后关闭编辑器并在Excel顶部菜单栏选择 开发工具 栏下的 插入 栏的 按钮（窗口控件） 在Excel中拖动创建一个按钮，并在之后弹出的窗口中选择 SplitExcel 项并点击 确定 按钮关闭窗口。
   
   
   
   
   

3. 进行拆分工作
   点击上一步创建好的按钮控件，并根据其弹出的窗口提示进行操作（由于分支过多，故在此不在赘述）。带程序提示处理完毕时，点击 确定 按钮关闭窗口。之后便可在当前表格存在的路径下看到处理的结果，具体如下所示。

五、备注

选择以xls格式导出后，在使用Excel打开导出结果会出现如下提示，点击 是 即可打开文档。

（此过程不会造成数据丢失，如果介意，建议选择xlsx格式导出！）
（此过程不会造成数据丢失，如果介意，建议选择xlsx格式导出！）
（此过程不会造成数据丢失，如果介意，建议选择xlsx格式导出！）