excel 宏 把一个工作表按照某几个列拆分为多个工作表

前言

这两天接触到excel比较多，才发现使用excel不仅仅是简单的复制粘贴。
excel vb代码是非常强大，学会使用一些常用的功能，可以大大减少工作量。
废话不多少，来看
如下表格学生成绩表

如果我们要把这个表按照班级拆分为三个表，可能一般我们都是通过筛选后复制粘贴。但这是最土的办法，并且如果分类很多，数据量又大的话，非常浪费时间。
来看使用excel宏轻松搞定。excel宏代码如下：

Option Explicit
Option Base 1
 
Sub 按指定列分组拆分数据()
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Dim self As Worksheet
    Set self = ActiveSheet
    
    Dim nLastRowNum As Long
    Dim nLastColumnNum As Long
    
    Dim i As Long
    
    ' 删除其他的sheet
    
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> self.Name Then
            Sheets(i).Delete
        End If
    Next i 
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True   
    
    '获取全部数据范围
    nLastRowNum = Cells(Rows.Count, 1).End(xlUp).Row
    nLastColumnNum = Cells(nLastRowNum, Columns.Count).End(xlToLeft).Column
    
    '获取标题
    Dim titleRange As Range
    Set titleRange = Application.InputBox(prompt:="请选择标题区域：将要当做标题行的每一个单元格", Type:=8)
     
    ' 有效数据开始行
    Dim nRowValidData As Long
    nRowValidData = titleRange.Row + titleRange.Rows.Count
 
    ' 获取拆分列的信息,只需要列号
    Dim splitColumnRange As Range
    Set splitColumnRange = Application.InputBox(prompt:="请选择拆分的列：选择任何一个该列的单元格即可", Type:=8)
    Dim columnNumToSplit As Long
    columnNumToSplit = splitColumnRange.Column
    
    ' 需要拆分的值字典
    Dim splitValueDict As Object
    ' 辅助字典用来保证顺序
    Dim splitValueDictReverse As Object
    Dim indexArray() As Long
    
    Set splitValueDict = CreateObject("Scripting.Dictionary")
    Set splitValueDictReverse = CreateObject("Scripting.Dictionary")
    
    Dim cellValue As String
    Dim ws As Worksheet
    
    For i = nRowValidData To nLastRowNum Step 1
        cellValue = Cells(i, columnNumToSplit).Text
        
        '1. 创建新的sheet；
        '2. 拷贝标题信息到新的sheet
        If Not splitValueDict.Exists(cellValue) Then
            splitValueDict(cellValue) = i
            splitValueDictReverse(i) = cellValue
            Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
            ws.Name = cellValue
            self.Activate
            
            titleRange.Copy _
                ws.Range(ws.Cells(titleRange.Row, titleRange.Column), ws.Cells(nRowValidData - 1, titleRange.Column))
            
        End If
        
        ' 拷贝其他内容
        
        Range(Cells(i, 1), Cells(i, nLastColumnNum)).Copy _
            GetLastPasteRangeBySheetName(cellValue, nLastColumnNum)
                
    Next i
            
End Sub
 
Public Function GetLastPasteRangeBySheetName(ByRef SheetName As String, columnNum As Long) As Variant
    Dim wks As Worksheet
    Dim nLastRowNum As Long
 
    Set wks = ActiveWorkbook.Worksheets(SheetName)
    nLastRowNum = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    Set GetLastPasteRangeBySheetName = wks.Range(wks.Cells(nLastRowNum + 1, 1), wks.Cells(nLastRowNum + 1, columnNum))
    
End Function

step 1 进入excel vba编程界面

在excel工作表中标签处右键查看代码

进入如下界面

step 2 粘贴代码

然后把代码粘贴窗口中如下图：

step 3 运行代码

点击下图中红框按钮

出现下面弹框

选择需要拆分标题区域。只需要用鼠标拖动选择区域即可

确定后再选择拆分的单元格，即按照班级拆分，选择班级

确定，结果如下

step 4 删除宏代码

如果为了保存方便，我们需要把宏代码删掉，不然保存需要保存为支持宏的格式。
运行成功后删除宏
找到工具 选择宏。

删除刚刚的宏即可，然后关闭代码，保存即可