能否按任意字段将总表拆分为多个分表？当然！ |
您所在的位置：网站首页 › excel函数公式left › 能否按任意字段将总表拆分为多个分表？当然！ |
能否按任意字段将总表拆分为多个分表？当然！
|
HI，大家好，我是星光。 之前给大家分享了过两段代码，分别是将多张分表的数据，按字段顺序或字段名称，快速汇总为一张总表。 罗老师说过，天下大势，合久必分。既然有多表汇总，也就有总表数据拆分。所以今天再给大家分享一段代码，作用是按任意列，将总表数据拆分为多个分表。 如下图所示的数据为例，是一张总表，标题行存在合并单元格等特殊情况，现在需要按任意字段，比如C列的班级字段，拆分为多张分表。
复制运行以下代码即可▼ 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代码详细解释见注释，概要说明如下： 第13至第14行代码调用getTitCount函数过程，获取用户在InputBox对话框中输入的标题行行数。 第17至第18行代码调用GetRngGistC函数过程，获取用户在Application.inputbox对话框中选择的拆分依据列。 第20行代码调用disAppSet过程，取消屏幕刷新等系统设置。 第22至第23行代码将总表数据存入数组aData，并获取获取总表实际存在数据的区域、首列、拆分依据列在实际区域中的第几列、首行和尾行等重要数据。这是由于首行首列未必是第一行第一列，比如本例所示的数据，也就导致拆分依据列的列标未必是实际处理数据的列标。 第31至第35行代码计算标题区域，并赋值变量rngTit。 第38行至第54行代码遍历拆分依据列，处理异常值，比如空格、错误值和可能以”/”为格式的日期值。 第13至第14行代码调用getTitCount函数过程，获取用户在InputBox对话框中输入的标题行行数。 第57至第69行代码通过前8行数据判断相关列是否为文本格式，避免文本型数值，比如身份证，在拆分后变形。代码将文本型数值所在的单元格地址赋值变量strADS。 第70至第106行代码按关键字拆分总表数据。其中第78至第85行代码遍历数据源将符合条件的数据存入数组aRes。第86至105行代码新建工作表，并将结果数组的数据写入该工作表，并设置标题行。 第111至第115行代码使用MsgBox函数以消息框的形式显示数据拆分结果信息。 …… 示例下载，百度网盘▼ https://pan.baidu.com/s/1i9RJD1PdsXoMI72neZNU2w 提取码: twwi |
【本文地址】
今日新闻 |
推荐新闻 |