常用功能加载宏——拆分工作表

      <button id="rbbtnSplitSht" label="拆分工作表" onAction="rbbtnSplitSht" imageMso="TableInsert" />

Sub rbbtnSplitSht(control As IRibbonControl)
    Call MShtWk.SplitSht
End Sub

Sub SplitSht()
    Dim rng As Range
    On Error Resume Next
    Set rng = Application.InputBox("请选择[标题行]、[拆分关键字列]所在的单元格", Default:=ActiveCell.Address, Type:=8)
    On Error GoTo 0
    
    If rng Is Nothing Then
        Exit Sub
    End If
    Set rng = rng.Range("A1")
    
    '字典记录每一个关键字对应的所有单元格
    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")
    
    '获取表格的列的范围
    Dim cols As Long
    cols = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
    
    '获取表格的最后所在的行
    Dim rows As Long
    '取消筛选
    ActiveSheet.AutoFilterMode = False
    rows = Cells(Cells.rows.Count, 1).End(xlUp).Row
    If rows <= rng.Row Then MsgBox "没有数据": Exit Sub
    
    '读取关键字所在列
    Dim arr() As Variant
    arr = Cells(1, rng.Column).Resize(rows, 1).Value
    
    Dim i As Long
    Dim strkey As String
    For i = rng.Row + 1 To rows
        strkey = VBA.CStr(arr(i, 1))
        If dic.Exists(strkey) Then
            '再次出现的关键字，合并
            Set dic(strkey) = Excel.Union(Cells(i, 1).Resize(1, cols), dic(strkey))
        Else
            '第一次出现的关键字，记录标题及当前行单元格
            Set dic(strkey) = Excel.Union(Cells(rng.Row, 1).Resize(1, cols), Cells(i, 1).Resize(1, 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(After:=Worksheets(Worksheets.Count)).Name = strkey
        items(i).Copy Range("A1")
    Next
End Sub