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

Sub SplitShByArr()Dim shtAct As Worksheet, sht As WorksheetDim rngData As Range, rngGistC As Range, rngTemp As RangeDim d As Object, aData, aKeys, vntDim intTitCount, strKey As String, strName As StringDim strADS As String, rngTit As RangeDim i As Long, j As Long, intFirstR As Long, intLastR As LongDim k As Long, x As Long, intActR As LongDim 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 '总表数据存入数组aDataintFirstC = rngData.Column '实际区域开始列intGistC = rngGistC.Column - intFirstC + 1 '依据列在aData中的序列intFirstR = rngData.Row '实际区域开始行intActR = intTitCount - intFirstR + 2 '扣除标题的数组开始行intLastR = GetintLastR(shtAct) '实际区域结束行With shtActSet 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) ThenaRef(i) = "错误值"ElseIf vnt = "" ThenaRef(i) = "空白单元格"ElseIf IsDate(vnt) Then '避免日期斜杠格式无法创建工作表aRef(i) = Format(vnt, "yyyy-m-d")ElseaRef(i) = vntEnd IfstrKey = 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 Forvnt = aData(i, j)If IsNumeric(vnt) Then '是否数值If VarType(aData(i, j)) = 8 Then '是否文本strADS = strADS & "," & Cells(1, j + intFirstC - 1).AddressExit ForEnd IfEnd IfNextNextstrADS = 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) '数据存入结果数组NextEnd IfNext''建立新工作表，存放结果数组DelSht (strName) '删除重名工作表With Worksheets.Add(after:=Sheets(Sheets.Count)) '新建工作表.Name = strName '命名If Err.Number Then '如果名称有特殊字符，则退出程序.DeleteGoTo errDescriptEnd IfIf Len(strADS) Then.Range(strADS).EntireColumn.NumberFormat = "@" '特殊列设置为文本格式End IfWith .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 WithNexterrDescript:shtAct.SelectCall reAppSet '恢复屏幕刷新等系统设置Set d = Nothing '释放字典内存If Err.Number ThenMsgBox Err.DescriptionElseMsgBox "拆分完成。"End IfEnd Sub'获取用户输入的标题行数Function getTitCount()Dim intTitCountintTitCount = InputBox("请输入标题行的行数", _Title:="Excel", _Default:=1)If StrPtr(intTitCount) = False ThengetTitCount = FalseExit FunctionEnd IfIf IsNumeric(intTitCount) = False ThenMsgBox "标题行的行数只能输入数字。"getTitCount = FalseExit FunctionEnd IfIf 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 ThenMsgBox "拆分依据列只能是单列。"Exit FunctionEnd IfSet GetRngGistC = rngGistCEnd Function'取消屏幕刷新，公式重算等Sub disAppSet()With Application.ScreenUpdating = False.Calculation = xlCalculationManual.DisplayAlerts = FalseEnd WithEnd Sub'恢复屏幕刷新等Sub reAppSet()With Application.ScreenUpdating = True.Calculation = xlCalculationAutomatic.DisplayAlerts = TrueEnd WithEnd Sub'删除重名工作表Function DelSht(ByVal strName As String)Dim sht As WorksheetFor Each sht In WorksheetsIf sht.Name = strName Thensht.DeleteExit FunctionEnd IfNextEnd Function'最大数据有效行Function GetintLastR(ByVal sht As Worksheet)GetintLastR = sht.Cells.Find("*", _LookIn:=xlFormulas, SearchOrder:=xlByRows, _SearchDirection:=xlPrevious).RowEnd Function