按任意字段将总表拆分为多个分表

Sub SplitShByArr()
    Dim shtAct As Worksheet, sht As Worksheet
    Dim rngData As Range, rngGistC As Range, rngTemp As Range
    Dim d As Object, aData, aKeys, vnt
    Dim intTitCount, strKey As String, strName As String
    Dim strADS As String, rngTit As Range
    Dim i As Long, j As Long, intFirstR As Long, intLastR As Long
    Dim k As Long, x As Long, intActR As Long
    Dim intFirstC As Long, intGistC As Long
    'On Error Resume Next '忽略错误继续运行程序
    '
    '获取用户输入的标题行数▼
    intTitCount = getTitCount()
    If intTitCount = False Then Exit Sub
    '
    '获取拆分依据列▼
    Set rngGistC = GetRngGistC()
    If Err.Number Then GoTo errDescript
    '
    Call disAppSet '取消屏幕刷新等系统设置
    '
    Set shtAct = ActiveSheet '当前工作表
    If shtAct.FilterMode = True Then shtAct.Cells.AutoFilter '取消筛选状态
    Set rngData = shtAct.UsedRange '实际区域
    aData = rngData.Value '总表数据存入数组aData
    intFirstC = rngData.Column '实际区域开始列
    intGistC = rngGistC.Column - intFirstC + 1 '依据列在aData中的序列
    intFirstR = rngData.Row '实际区域开始行
    intActR = intTitCount - intFirstR + 2 '扣除标题的数组开始行
    intLastR = GetintLastR(shtAct) '实际区域结束行
    With shtAct
        Set rngTit = .Range(.Cells(1, 1), _
                        .Cells(intTitCount, _
                            UBound(aData, 2) + intFirstC - 1)) '标题区域
    End With
    '
    '参数数组，修正异常数据▼
    Set d = CreateObject("scripting.dictionary") '后期字典
    ReDim aRef(1 To intLastR) '数组aRef，修正拆分列特殊数据
    For i = intActR To UBound(aData)
        If i > intLastR Then Exit For '如果大于有效数据最大行则退出循环
        vnt = aData(i, intGistC)
        If IsError(vnt) Then
            aRef(i) = "错误值"
        ElseIf vnt = "" Then
            aRef(i) = "空白单元格"
        ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作表
            aRef(i) = Format(vnt, "yyyy-m-d")
        Else
            aRef(i) = vnt
        End If
        strKey = aRef(i)
        d(strKey) = d(strKey) + 1 '记录不同拆分关键字的数量
    Next
    '
    '通过前8行数据来判断该列是否为特殊的文本数值
    For j = 1 To UBound(aData, 2) '遍历列
        For i = intActR To UBound(aData) '遍历前8行
            If i > 8 Then Exit For
            vnt = aData(i, j)
            If IsNumeric(vnt) Then '是否数值
                If VarType(aData(i, j)) = 8 Then '是否文本
                    strADS = strADS & "," & Cells(1, j + intFirstC - 1).Address
                    Exit For
                End If
            End If
        Next
    Next
    strADS = Mid(strADS, 2) '需要设置文本格式的单元格地址
    '
    aKeys = d.keys '字典Keys，拆分关键字数组
    For i = 0 To UBound(aKeys) '遍历关键字
        strName = aKeys(i) '关键字
        ReDim aRes(1 To d(strName), 1 To UBound(aData, 2)) '结果数组
        k = 0 '计数器归0
        '
        '筛选符合条件的记录存入结果数组
        For x = 1 To UBound(aRef)
            If aRef(x) = strName Then '如果关键字符合
                k = k + 1 '累加符合条件的行
                For j = 1 To UBound(aData, 2) '遍历列
                    aRes(k, j) = aData(x, j) '数据存入结果数组
                Next
            End If
        Next
        '
        '建立新工作表，存放结果数组
        DelSht (strName) '删除重名工作表
        With Worksheets.Add(after:=Sheets(Sheets.Count)) '新建工作表
            .Name = strName '命名
            If Err.Number Then '如果名称有特殊字符，则退出程序
                .Delete
                GoTo errDescript
            End If
            If Len(strADS) Then
                .Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式
            End If
            With .Cells(intTitCount + 1, intFirstC).Resize(k, UBound(aRes, 2))
                .Value = aRes '结果数组数据写入工作表
            End With
            .UsedRange.Borders.LineStyle = 1 '设置边框线
            rngTit.Copy
            .Range("a1").PasteSpecial xlPasteColumnWidths '粘贴列宽
            .Range("a1").PasteSpecial xlPasteAll '粘贴标题
        End With
    Next
errDescript:
    shtAct.Select
    Call reAppSet '恢复屏幕刷新等系统设置
    Set d = Nothing '释放字典内存
    If Err.Number Then
        MsgBox Err.Description
    Else
        MsgBox "拆分完成。"
    End If
End Sub

'获取用户输入的标题行数
Function getTitCount()
    Dim intTitCount
    intTitCount = InputBox("请输入标题行的行数", _
                        Title:="公众号Excel星球", _
                        Default:=1)
    If StrPtr(intTitCount) = False Then
        getTitCount = False
        Exit Function
    End If
    If IsNumeric(intTitCount) = False Then
        MsgBox "标题行的行数只能输入数字。"
        getTitCount = False
        Exit Function
    End If
    If intTitCount < 0 Then
        MsgBox "标题行数不能为负数。"
        getTitCount = False
        Exit Function
    End If
    getTitCount = intTitCount
End Function

'用户选择拆分依据列
Function GetRngGistC() As Range
    Dim rngGistC As Range
    Set rngGistC = Application.InputBox("请选择拆分依据列。", _
                    Title:="公众号Excel星球", _
                    Default:=Selection.Address, _
                    Type:=8)
    If rngGistC Is Nothing Then
        Exit Function
    End If
    If rngGistC.Columns.Count > 1 Then
        MsgBox "拆分依据列只能是单列。"
        Exit Function
    End If
    Set GetRngGistC = rngGistC
End Function

'取消屏幕刷新，公式重算等
Sub disAppSet()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
End Sub

'恢复屏幕刷新等
Sub reAppSet()
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

'删除重名工作表
Function DelSht(ByVal strName As String)
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Name = strName Then
            sht.Delete
            Exit Function
        End If
    Next
End Function

'最大数据有效行
Function GetintLastR(ByVal sht As Worksheet)
    GetintLastR = sht.Cells.Find("*", _
        LookIn:=xlFormulas, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
End Function