VBA拆分表格

Enum RetCode
    ErrRT = -1
    SuccRT = 1
End Enum

Enum Pos
    RowStart = 2
    
    年龄段 = 6
    
    KeyCol = 年龄段
    Cols = 年龄段
End Enum

Type DataStruct
    Src() As Variant
    Rows As Long
    Cols As Long
    
    Result() As Variant
End Type

Sub vba_main()
    Dim d As DataStruct
    
    If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
    If RetCode.ErrRT = GetResult(d) Then Exit Sub
End Sub

Private Function GetResult(d As DataStruct) As RetCode
    Dim dic As Object

    Set dic = VBA.CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    Dim strkey As String
    For i = Pos.RowStart To d.Rows
        strkey = VBA.CStr(d.Src(i, Pos.KeyCol))
        If dic.Exists(strkey) Then
            '再次出现的关键字，合并
            Set dic(strkey) = Excel.Union(Cells(i, 1).Resize(1, Pos.Cols), dic(strkey))
        Else
            '第一次出现的关键字，记录标题及当前行单元格
            Set dic(strkey) = Excel.Union(Cells(1, 1).Resize(1, Pos.Cols), Cells(i, 1).Resize(1, Pos.Cols))
        End If
    Next
    
    Dim keys As Variant
    keys = dic.keys()
    Dim items As Variant
    items = dic.items()
    '新建表并复制单元格
    For i = 0 To UBound(keys)
        strkey = VBA.CStr(keys(i))
        '注：这里没有去考虑sheet的名称是否合规，sheet名称是不能包含" / \ 等字符的"
        Worksheets.Add().Name = strkey
        items(i).Copy Range("A1")
    Next
End Function

Private Function ReadSrc(d As DataStruct) As RetCode
    ReadSrc = ReadData(d.Src, d.Rows, Pos.Cols, Pos.KeyCol, Pos.RowStart)
End Function

Private Function ReadData(ByRef RetArr() As Variant, ByRef RetRow As Long, Cols As Long, KeyCol As Long, RowStart As Long) As RetCode
    ActiveSheet.AutoFilterMode = False
    RetRow = Cells(Cells.Rows.Count, KeyCol).End(xlUp).Row
    If RetRow < RowStart Then
        MsgBox "没有数据"
        ReadData = RetCode.ErrRT
        Exit Function
    End If
    RetArr = Cells(1, 1).Resize(RetRow, Cols).Value

    ReadData = RetCode.SuccRT
End Function