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

 
前言
 
这两天接触到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 删除宏代码
 
如果为了保存方便，我们需要把宏代码删掉，不然保存需要保存为支持宏的格式。
 运行成功后删除宏
 找到工具 选择宏。
 
 删除刚刚的宏即可，然后关闭代码，保存即可
 

 
 
Excel 2016 
 参考https://jingyan.baidu.com/article/d7130635071d2313fdf47585.html
 
 
有时候需要在一个工作簿中建立多个工作表，并且需要自定义工作表的名称，手动的一个个双击表名去修改非常麻烦，特别是这次我需要建立一百多个表的时候。。。。
 


 
 
  
方法一：使用数据透视表功能
方法二 使用VB写模块工具
    
ecxel 自定义模块
使用宏控件
 
后续操作
excel2010版本
 
 
 
 
 
方法一：使用数据透视表功能
 
插入->数据透视表 
 
选择表名数据区域，并且为新的区域 
 
把空白框中的待选项拖动到筛选框中
 
 
数据透视表工具-> 选项->显示报表筛选页
 
 
然后确定 
 
 
方法二 使用VB写模块工具
 
总的数据表类似于 
 
 
一个课号100多个学生，然后根据一个总的成绩表来建立每个学生的这样评分信息表，如果手动去复制粘贴就显得很麻烦了 
 
 
所以就在上面的自动建立多个表的基础上，在建立的过程中把每个人的数据也自动的导入到每张表中方便使用。
 
ecxel 自定义模块
 
首先需要启用宏功能 
 文件-》选项-》信任中心-》信任中心设置-》宏设置-》启用所有宏 
 
excel文件另存为启用宏的工作簿 
 
建立模块 
 按alt+F11-》选项栏中选择 插入-》模块 
 
 
这可以完美兼容office16，应该也可以在13上使用，但是在10版本上需要修改才可以使用，需要在excel2010上使用的直接拉到最后
 
把下面的代码复制粘贴到代码框中然后保存ctrl +S，直接关闭VB编辑窗口，回到主界面。
 
Sub CFGZB()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As Variant
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "数据源" Then
            Sheets(i).Delete
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("数据源").UsedRange.Rows.Count
    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k)
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
        Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
        Worksheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k(i)
            For num = 1 To UBound(myArray)
                .Cells(1, num) = myArray(num, 1)
            Next num
            .Range("A2").CopyFromRecordset conn.Execute(Sql)
        End With
        Sheets(1).Select
        Sheets(1).Cells.Select
        Selection.Copy
        Worksheets(Sheets.Count).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
在空白处右键 -》自定义功能区-》勾选开发工具 
  
 
 
使用宏控件
 
开发工具-》插入按钮，选择我们刚才的自定义的宏 
  
  
 然后把我们的保存数据的表名称改为 数据源 
 直接点击按钮根据提示操作 
  
 
 
如果提示文本类型错误需要把作为表名称的数据存在数字类型改为文本类型。 
 然后卡一下就完成了
 
 
后续操作
 
把每个人数据建立成一个个人分析表
 
全选工作表除了数据源，后面的操作都是在一个表操作，然后所有选中的工作表都会自动同步。
把个人数据移动到合适位置 
 
（第一次）复制粘贴模板 
 
如果出现格式不一致，需要在第一次粘贴过来，粘贴内容还在选中状态，点击 开始-》粘贴-》保持列宽。就可以还原原来的格式了。 
 
然后就是把刚才分表过程中分配过来的数据根据选项引用就行了 
 
 
  
在一个引用之后使用，选中刚才已经引用数据的单元格，在开始-》填充-》至同组工作表。就可以把所有的表的同个位置进行引用数据。 
 
其他的数据也是这样一个个的填，填完之后对表格区域选定，进行复制，然后不要动，直接选择 开始-》粘贴-》粘贴为值。再把引用的数据删除就ok了 
 
 
excel2010版本
 
参考原作者https://jingyan.baidu.com/article/d7130635071d2313fdf47585.html
 
数据格式报错修改方法
 
把原来的title定义
Dim title As String
修改wei
Dim title As Variant
 
sheets(i).delete这句代码出错，要拆分的数据工作表名称为“数据源”，而不是新建工作簿时的sheet1这种。手动改成“数据源”即可。

  excel如按某一列拆分成多个工作表（支持多列），或多个Excel文件，或按某几列拆分成多个文件。
 
 
 
  使用这个在线工具，无需vba，不用复杂的透视表，地址：http://www.excelfb.com/ ,点击： 拆分表--》（按指定列）拆分成多个表
 
 操作如下图：（如果是多列，例如A列和B列，在按第几列填入A，B  用‘，’隔开A和B）
 
 
 
   

 本例介绍在excel中如何将一个工作表根据条件拆分成多个工作表。
 
 注意：很多朋友反映sheets(i).delete这句代码出错，要注意下面第一个步骤，要拆分的数据工作表名称为“数据源”，而不是你新建工作簿时的sheet1这种。手动改成“数据源”即可。
 
 
 
 操作步骤：
 
 原始数据表如下（名称为：数据源），需要根据B列人员姓名拆分成每个人一个工作表。
 
 
 
 点击【开发工具】-【Visual Basic】或者Alt+F11的快捷键进入VBE编辑界面。
 
 
 
 如下图所示插入一个新的模块。
 
 
 
 
 
 如下图，粘贴下列代码在模块中：
 
 
 复制内容到剪贴板 
 
 
  
 Sub CFGZB()   
   
     Dim myRange As Variant   
   
     Dim myArray   
   
     Dim titleRange As Range   
   
     Dim title As String   
   
     Dim columnNum As Integer   
   
     myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)   
   
     myArray = WorksheetFunction.Transpose(myRange)   
   
     Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)   
   
     title = titleRange.Value   
   
     columnNum = titleRange.Column   
   
     Application.ScreenUpdating = False   
   
     Application.DisplayAlerts = False   
   
     Dim i&, Myr&, Arr, num&   
   
     Dim d, k   
   
     For i = Sheets.Count To 1 Step -1   
   
         If Sheets(i).Name <> "数据源" Then   
   
             Sheets(i).Delete   
   
         End If   
   
     Next i   
   
     Set d = CreateObject("Scripting.Dictionary")   
   
     Myr = Worksheets("数据源").UsedRange.Rows.Count   
   
     Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))   
   
     For i = 1 To UBound(Arr)   
   
         d(Arr(i, 1)) = ""  
   
     Next   
   
     k = d.keys   
   
     For i = 0 To UBound(k)   
   
         Set conn = CreateObject("adodb.connection")   
   
         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName   
   
         Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"  
   
         Worksheets.Add after:=Sheets(Sheets.Count)   
   
         With ActiveSheet   
   
             .Name = k(i)   
   
             For num = 1 To UBound(myArray)   
   
                 .Cells(1, num) = myArray(num, 1)   
   
             Next num   
   
             .Range("A2").CopyFromRecordset conn.Execute(Sql)   
   
         End With   
   
         Sheets(1).Select   
   
         Sheets(1).Cells.Select   
   
         Selection.Copy   
   
         Worksheets(Sheets.Count).Activate   
   
         ActiveSheet.Cells.Select   
   
         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _   
   
                                SkipBlanks:=False, Transpose:=False   
   
         Application.CutCopyMode = False   
   
     Next i   
   
     conn.Close   
   
     Set conn = Nothing   
   
     Application.DisplayAlerts = True   
   
     Application.ScreenUpdating = True   
   
 End Sub   
   
 
 
 
 
 
 
 5、如下图所示，插入一个控件按钮，并指定宏到刚才插入的模块代码。
 
 
 
 
 
 6、点击插入的按钮控件，根据提示选择标题行和要拆分的列字段，本例选择“姓名”字段拆分，当然也可以选择C列的“名称”进行拆分，看实际需求。
 
 
 
 
 
 
 
 
 
 7、代码运行完毕后在工作簿后面会出现很多工作表，每个工作表都是单独一个人的数据。具体如下图所示：
 
 
 
 8、注意：
 
 1）原始数据表要从第一行开始有数据，并且不能有合并单元格；
 
 2）打开工作簿时需要开启宏，否则将无法运行代码。
 
 以上就是excel将一个工作表根据条件拆分成多个工作表图文教程，希望能对大家有所帮助！