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

心已赠人 2024-04-17 21:29 30阅读 0赞

###  ###

*   *  前言
     *  step 1 进入excel vba编程界面
     *  step 2 粘贴代码
     *  step 3 运行代码
     *  step 4 删除宏代码

## 前言 ##

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

如果我们要把这个表按照班级拆分为三个表，可能一般我们都是通过筛选后复制粘贴。但这是最土的办法，并且如果分类很多，数据量又大的话，非常浪费时间。  
来看使用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工作表中标签处右键查看代码  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 1]

进入如下界面  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 2]

## step 2 粘贴代码 ##

然后把代码粘贴窗口中如下图：  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 3]

## step 3 运行代码 ##

点击下图中红框按钮  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 4]  
出现下面弹框  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 5]  
选择需要拆分标题区域。只需要用鼠标拖动选择区域即可  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 6]  
确定后再选择拆分的单元格，即按照班级拆分，选择班级  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 7]  
确定，结果如下  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 8]

## step 4 删除宏代码 ##

如果为了保存方便，我们需要把宏代码删掉，不然保存需要保存为支持宏的格式。  
运行成功后删除宏  
找到工具 选择宏。  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 9]  
删除刚刚的宏即可，然后关闭代码，保存即可  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 10]

[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/99aff98a7074438d86f31e699a717b8c.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 1]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/7c3e3f4c89b442aeb26dc74afd41c3c7.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 2]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/fd8ba7c23bd04e2a8f90f7ea28cfbe04.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 3]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/011af58daea24919b2cb4875ce8ea08a.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 4]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/2a8cb460fa4447a9ab0be61d82635ff6.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 5]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/626a0d503f304fb2b3a3d584b32db679.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 6]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/5c0d6e35f09e466f948d7ecb8872cf7b.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 7]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/28207e12a72a4ae3909cf48ff5fb98a7.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 8]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/545ed3e013c14f549a7732cdbde5f49e.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 9]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/a8870f09298549a29b6277a42c5140a3.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3doYW5kZ2Ro_size_16_color_FFFFFF_t_70 10]: https://image.dandelioncloud.cn/pgy_files/images/2024/04/17/b9c86a434abd46ebb02491f2e0079309.png