写几段代码，将总表按任意列拆分为多个事情簿

各人好，我是星光。
本日和各人分享的VBA小代码是：一键将总表按任意列拆分为多个事情簿

什么意思呢？举个小栗子。
如下图所示，是一张总表，此刻需要按任意列，好比班级列吧，将它拆分为多个事情簿。

动画演示如下：

VBA代码如下：

Sub SplitShByArr() Dim shtAct As Worksheet, sht As Worksheet, wb As Workbook 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 Dim strPath As String On Error Resume Next '忽略错误继承运行措施 ' strPath = getStrPath() '用户选择文件生存路径 If strPath = "" Then Exit Sub ' '获取用户输入的标题行数▼ 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 ' '成立新事情簿，抖客教程网，存放功效数组 Set wb = Workbooks.Add With wb.Worksheets(1) .Name = strName '定名 If Err.Number Then '假如名称有非凡字符，则退出措施 .Delete wb.Close False 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 wb.SaveAs strPath & strName wb.Close False Next errDescript: shtAct.Select Call reAppSet '规复屏幕刷新等系统配置 Set d = Nothing '释放字典内存 If Err.Number Then MsgBox Err.Description Else MsgBox "拆分完成。" End If End Sub '用户选择文件夹路径 Function getStrPath() As String Dim strPath As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then strPath = .SelectedItems(1) Else '如用户为选中文件夹则退出 Exit Function End If End With If Right(strPath, 1) <> "\" Then strPath = strPath & "\" getStrPath = strPath End Function '获取用户输入的标题行数 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 GetintLastR(ByVal sht As Worksheet) GetintLastR = sht.Cells.Find("*", _ LookIn:=xlFormulas, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row End Function

代码具体表明见注释，提要说明如下▼

第13至第14行代码，挪用getStrPath函数进程，打开文件欣赏对话框，答允用户选择任意文件夹作为数据源；假如用户未选取文件夹，则退出措施。

第17至第18行代码，挪用getTitCount进程，答允用户输入指定行数的标题行。

第21至第22行代码，挪用GetRngGistC进程，答允用户选择拆分依据列。

第24行代码，挪用disAppSet进程，打消屏幕刷新等系统配置。