能否按任意字段将总表拆分为多个分表？当然！

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    NexterrDescript:    shtAct.Select    Call reAppSet '恢复屏幕刷新等系统设置    Set d = Nothing '释放字典内存    If Err.Number Then        MsgBox Err.Description    Else        MsgBox "拆分完成。"    End IfEnd 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 = intTitCountEnd 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 = rngGistCEnd Function
'取消屏幕刷新，公式重算等Sub disAppSet()    With Application        .ScreenUpdating = False        .Calculation = xlCalculationManual        .DisplayAlerts = False    End WithEnd Sub
'恢复屏幕刷新等Sub reAppSet()    With Application        .ScreenUpdating = True        .Calculation = xlCalculationAutomatic        .DisplayAlerts = True    End WithEnd 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    NextEnd Function
'最大数据有效行Function GetintLastR(ByVal sht As Worksheet)    GetintLastR = sht.Cells.Find("*", _        LookIn:=xlFormulas, SearchOrder:=xlByRows, _        SearchDirection:=xlPrevious).RowEnd Function