【VBA宏】excel按照某列分组，进行同表sheet页拆分

在工作中，遇到需要将总表按照某列，拆分成多个小表的需求，先将表格去除单元格合并，格式调整统一，然后通过VBA代码实现拆分，这里的拆分方法借鉴使用了努力赚小目标的小葱同学的链接：使用Excel编辑器按照选定某列相同内容拆分sheet_excel按某一列拆分sheet-CSDN博客文章浏览阅读231次。将“要被拆分的sheet名”更改为自己当前需要被拆分的sheet名即可。选择需要拆分的列号即可。_excel按某一列拆分sheethttps://blog.csdn.net/weixin_51319361/article/details/140124867

 其中需要把自己要拆分的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

 拆分完之后，表格的列宽和布局会默认原格式，如需调整列宽，如果你的工作表中的数据列数不固定，或者你想要根据内容自动调整列宽（而不是设置为固定的宽度），可以使用AutoFit方法。但是，请注意，AutoFit可能会使列宽变得非常宽，特别是当单元格中包含很长的文本时。

Sub AutoFitAllSheetsColumns()  
    Dim ws As Worksheet  
      
    ' 遍历工作簿中的所有工作表  
    For Each ws In ThisWorkbook.Worksheets  
        ' 自动调整所有列的宽度  
        ws.UsedRange.Columns.AutoFit  
    Next ws  
      
    MsgBox "所有工作表的列宽已根据内容自动调整。"  
End Sub