使用Excel编辑器按照选定某列相同内容拆分sheet

将“要被拆分的sheet名”更改为自己当前需要被拆分的sheet名即可。 

Sub SplitDataByColumn()
    '作用：根据当前工作表的某列，把全表的数据拆分到多个工作表中分别存储
    Dim lastRow As Long, currentRow As Long, byWhichColumn As Long, currentValue As String
    Dim currentSheet As Worksheet, newSheet As Worksheet, currentHeader As Range
    Dim currentRange As Range, sourceSheet As Worksheet, t As Single
    t = Timer
    Set sourceSheet = ThisWorkbook.Worksheets("要被拆分的sheet名")
    lastRow = sourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    '获取用户指定的拆分依据列号, 输入 1 表示按工作表的第 1 列拆分, 以此类推
    byWhichColumn = Application.InputBox("请输入要拆分的列号：", "拆分表格", 2, Type:=1)
    
    '获取表头行, 默认为 A1 所在的行就是表头, 有需要也可更改为其他单元格
    Set currentHeader = sourceSheet.Range("A1").EntireRow
    
    '循环遍历源工作表的每一行
    For currentRow = currentHeader.Row + 1 To lastRow
        '获取当前行指定列的值
        currentValue = sourceSheet.Cells(currentRow, byWhichColumn).Value
        
        '检查是否需要新建工作表
        On Error Resume Next
        Set currentSheet = Nothing
        Set currentSheet = ThisWorkbook.Worksheets(currentValue)
        If currentSheet Is Nothing Then
            '新建工作表
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
            newSheet.Name = currentValue
            
            '将表头复制到新工作表的 A1 单元格所在行
            currentHeader.Copy newSheet.Range("A1")
        End If
        On Error GoTo 0
        
        '将当前行复制到相应的工作表
        Set currentRange = sourceSheet.Cells(currentRow, 1).EntireRow
        currentRange.Copy ThisWorkbook.Worksheets(currentValue).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next currentRow
    
    MsgBox "拆分完成" & vbCrLf & vbCrLf & "共用时: " & Format(Timer - t, "0.0 秒"), vbOKOnly + vbInformation, "提示"
    
End Sub

选择需要拆分的列号即可。