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