VBA按列拆分到多个工作表

需求：一个工作表中按某列值，不同的值拆分到不同的工作簿，并以这个工作簿命名

简易插件如下：

功能区编辑可参考：可结合自己需求编辑美化
https://blog.csdn.net/me_to_007/article/details/118260245

操作方法：
进入目标工作表 -> 点击功能区下的“sheet_cut”按钮 -> 弹出窗体填写要拆分的列及是否包含表头 -> 下方点击“点击开始拆分”按钮

效果如下图：

简易窗体：只设置了几个简单控件，没有添加错误校验（可按需编辑）

相关代码如下：
功能区面板按钮：

Sub sheet_cut(ByVal control As IRibbonControl)
' 这里是插入一个按钮，过程必须指明形参，比如这里是IRibbonControl

' 按列拆分到多个工作表

UserForm2.TextBox1.Value = "A"   ' 初始化为按A列拆分
UserForm2.OptionButton1.Value = True    ' 默认带表头

UserForm2.Show

End Sub

窗体“关闭窗口”，这里直接关闭窗体

Private Sub CommandButton2_Click()
' 关闭窗体
Unload Me

End Sub

窗体“点击开始拆分”按钮执行代码：

Private Sub CommandButton1_Click()
' 拆改工作表

On Error Resume GoTo line1

Dim arr, arr1
Dim i, start_row, end_row, goal_col, write_row, col_num, max_col As Long
Dim col As String
Dim this_path As String
Dim d As Object
Dim k
Dim wb As Workbook

Application.ScreenUpdating = False    ' 关闭屏幕刷新

col = UserForm2.TextBox1.Value    ' 获取文本控件的值
start_row = 2   
If UserForm2.OptionButton1.Value = False Then start_row = 1   ' 如果有表头从第二行开始
col = UserForm2.TextBox1.Value    ' 按哪列拆分，从窗体文本控件里读取
end_row = ActiveSheet.Range(col & "1").End(xlDown).Row      ' 最大行
max_col = ActiveSheet.Range(col & "1").End(xlToRight).Column
goal_col = ActiveSheet.Range(col & "1").Column
arr = ActiveSheet.UsedRange

Set d = CreateObject("scripting.dictionary")    ' 字典对象
For i = start_row To end_row     '  筛选字段去重
	d(Range(col & i).Value) = ""   ' 去重
Next

this_path = ActiveWorkbook.Path & "\"    ' 输出文件路径，同当前工作簿

' 便利字段每一个值筛选写入一个工作簿
For Each k In d.keys
    ReDim arr1(1 To UBound(arr), 1 To max_col)     ' vba的筛选数组的行一旦确定了不可更改，这里直接取最大行，写起来简单些，不用涉及转置什么
    write_row = 1
    If start_row = 2 Then    ' 如果有表头，先填表头
         For col_num = 1 To max_col
            arr1(1, col_num) = arr(1, col_num)
         Next
         write_row = write_row + 1
    End If
    ' 数据筛选
    For i = start_row To end_row    
        If arr(i, goal_col) = k Then
           For col_num = 1 To max_col
               arr1(write_row, col_num) = arr(i, col_num)
            Next
            write_row = write_row + 1
        End If
    Next
    If write_row >= 2 Then
        Set wb = Workbooks.Add   ' 新建工作簿
        wb.Worksheets("Sheet1").Range("a1").Resize(UBound(arr), max_col).Value = arr1     ' 内容写入
        wb.SaveAs this_path & k & ".xlsx"     ' 文件保存
        wb.Close True
    End If   
Next
MsgBox "已经拆分完成，拆分文件见目录：" & this_path

GoTo line1:
Application.ScreenUpdating = True       ' 恢复屏幕刷新
Unload Me        ' 关闭窗体


End Sub

需要现成插件的，评论区扣1

插件设置加载后，打开任何一个工作簿都会自动加载插件，可使用插件功能，比如自定义函数，其他功能等。