VBA 指定字段拆分工作表(数组)

Sub Sht_Array() '数组拆分
    Dim aData, aRes, Dic, Mat, T
    Dim strShtName, strErr$, strMsg$, s$
    Dim x&, y&, iRow&, k&, intY&
    Dim Cell As Range, Rng As Range, TitleRng As Range
    Dim Sht As Worksheet, ActSht As Worksheet
    On Error Resume Next
    Set ActSht = ActiveSheet
    Set Rng = 模块.SetRng("选择需要拆分的所在列" & Chr(10) & "注意:只能选取一列作为拆分依据")
    If Rng Is Nothing Then MsgBox "请重新选择", 64, "提示": Exit Sub
    If Rng.Columns.Count > 1 Then MsgBox "只能选择一列,太多了干不过来~~", 64, "提示": Exit Sub
    iRow = 模块.SetRow("请选择标题的行数,不能为负数")
    If iRow < 0 Then MsgBox "只能是大于0的正数", 64, "提示!": Exit Sub
    T = Timer
    With ActSht
        Set Cell = .UsedRange
        aData = Cell
        Set TitleRng = .Range(.Cells(Cell.Column, 1), .Cells(iRow, UBound(aData, 2)))
    End With
    Set Dic = CreateObject("Scripting.Dictionary") '后期绑定字典
    y = Rng.Column - Cell.Column + 1 '实际需要拆分的所在列位置
    For x = iRow + 1 To UBound(aData)
        Dic(aData(x, y)) = "" '实际拆分列的数据作为关键字存入字典
    Next
    Call 模块.AppEx
    For Each Mat In Dic.keys '遍历字典所有的关键字
        strShtName = Mat
        k = 0 '初始化计数器
        ReDim aRes(1 To UBound(aData), 1 To UBound(aData, 2)) '遍历数据源
        For x = iRow + 1 To UBound(aData)
            If strShtName = aData(x, y) Then '如果符合条件
                k = k + 1
                For intY = 1 To UBound(aData, 2)
                    aRes(k, intY) = aData(x, intY)
                Next
            End If
        Next
        strShtName = 模块.GetShtName(Mat) '根据数据决定工作表名称
        Worksheets(strShtName).Delete '删除工作表
        Err.Clear
        With Sheets.Add(after:=Sheets(Sheets.Count)) '新建工作表
            .Name = strShtName
        End With
        If Err Then '如果出错
            strErr = strErr & Chr(10) & strShtName '记录错误信息
            ActiveSheet.Delete
        Else
            strMsg = strMsg & Chr(10) & strShtName
            With Worksheets(strShtName) '在工作表中写入表头以及内容
                TitleRng.Copy .Range("a1")
                .Cells(.Cells(Rows.Count, 1).End(3).Row + 1, 1).Resize(k, UBound(aRes, 2)) = aRes
                .UsedRange.Borders.LineStyle = 1 '添加边框
                .Columns.AutoFit '自适应列宽
            End With
        End If
    Next
    ActSht.Select
    If strMsg <> "" Then s = "成功创建以下工作表:" & Chr(10) & Mid(strMsg, 2)
    If strErr <> "" Then s = s & Chr(10) & Chr(10) & "您为工作表或图标输入的名称无效。请确保:" & Chr(10) _
        & "※名称不多于31个字符。" & Chr(10) _
        & "※名称不包含下列任一字符:\/?*[或]。" & Chr(10) _
        & "※名称不为空。" & Chr(10) _
        & "创建失败名称如下 " & Chr(10) & Mid(strErr, 2)
    MsgBox s & Chr(10) & "总共花费了:" & Format(Timer - T, "0.0000秒")
    Call 模块.AppEx(True)
    Set Dic = Nothing
End Sub