纯干货分享-超实用的DeepSeek+EXCEL组合,一键解决拆分表格的头疼问题
- 2026-11-08 22:12:57
1.请帮我把工作表拆分成多个不同的工作表
2.并且你还要保证拆分过后的分表与原表格的格式保持一致
3.你还要弹出一个弹窗，在弹窗当中我可以选择按照哪一列进行拆分
4.请根据我以上所有的需求帮我编写出一段对应的VBA代码
DeepSeek给出以下代码：
Option Explicit
Sub SplitSheetByColumn()
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim titleRow As Long: titleRow = 1 ' 标题所在行（假设为第1行）
Dim splitColInput As Variant
Dim splitColNum As Integer
Dim dict As Object
Dim i As Long
Dim key As Variant
Dim wsNew As Worksheet
Dim colIndex As Integer
On Error GoTo ErrorHandler
' 获取当前活动工作表
Set ws = ActiveSheet
' 弹窗让用户输入拆分列
splitColInput = InputBox("请输入拆分依据的列（列字母，如 A，或列号，如 1）:", "拆分列选择")
If splitColInput = "" Then Exit Sub
' 将输入转换为列号
If IsNumeric(splitColInput) Then
splitColNum = CInt(splitColInput)
If splitColNum < 1 Or splitColNum > ws.Columns.Count Then
MsgBox "列号超出范围。"
Exit Sub
End If
Else
splitColNum = ColumnLetterToNumber(CStr(splitColInput))
If splitColNum = 0 Then
MsgBox "无效的列字母。"
Exit Sub
End If
End If
' 获取数据区域范围
With ws
lastRow = .Cells(.Rows.Count, splitColNum).End(xlUp).Row
lastCol = .Cells(titleRow, .Columns.Count).End(xlToLeft).Column
If lastRow < titleRow Then
MsgBox "没有数据。"
Exit Sub
End If
End With
' 使用字典存储每个类别的行集合
Set dict = CreateObject("Scripting.Dictionary")
For i = titleRow + 1 To lastRow
key = ws.Cells(i, splitColNum).Value
If key = "" Then key = "(空白)" ' 空单元格归为一类
If Not dict.Exists(key) Then
Set dict(key) = ws.Rows(i)
Else
Set dict(key) = Union(dict(key), ws.Rows(i))
End If
Next i
' 关闭屏幕更新和警告提示，加快速度并避免弹窗
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 遍历字典，为每个类别创建新工作表
For Each key In dict.keys
' 生成合法的工作表名称
Dim sheetName As String
sheetName = MakeValidSheetName(CStr(key))
' 删除可能已存在的同名工作表
On Error Resume Next
Sheets(sheetName).Delete
On Error GoTo 0
' 新建工作表并命名
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
wsNew.Name = sheetName
' 复制标题行（保留格式）
ws.Rows(titleRow).Copy Destination:=wsNew.Rows(1)
' 设置列宽与原表完全一致
For colIndex = 1 To lastCol
wsNew.Columns(colIndex).ColumnWidth = ws.Columns(colIndex).ColumnWidth
Next colIndex
' 复制该类别的所有数据行（保留格式）
dict(key).Copy Destination:=wsNew.Rows(titleRow + 1)
Next key
' 恢复设置
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "拆分完成！共创建 " & dict.Count & " 个工作表。"
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "发生错误：" & Err.Description
End Sub
' 将列字母转换为数字（例如 "A"→1，"AB"→28）
Function ColumnLetterToNumber(ByVal colLetter As String) As Integer
Dim colNum As Integer
colLetter = UCase(Trim(colLetter))
If Len(colLetter) = 1 Then
colNum = Asc(colLetter) - Asc("A") + 1
ElseIf Len(colLetter) = 2 Then
colNum = (Asc(Left(colLetter, 1)) - Asc("A") + 1) * 26 + (Asc(Right(colLetter, 1)) - Asc("A") + 1)
Else
colNum = 0
End If
ColumnLetterToNumber = colNum
End Function
' 生成合法的工作表名称：替换非法字符，截断至31字符
Function MakeValidSheetName(ByVal rawName As String) As String
Dim invalidChars As Variant
Dim i As Integer
Dim result As String
' 常见的非法字符（工作表名称中不能包含的）
invalidChars = Array("/", "\", "?", "*", "[", "]", ":", "'")
result = rawName
For i = LBound(invalidChars) To UBound(invalidChars)
result = Replace(result, invalidChars(i), " ")
Next i
' 去除首尾空格，截断长度
result = Trim(result)
If Len(result) > 31 Then result = Left(result, 31)
If result = "" Then result = "Sheet" ' 如果名称为空，使用默认名
MakeValidSheetName = result
End Function
二、打开EXCEL（示例为wps软件下的），点击"工具"->VB编辑器，图示如下：
