前言
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中，怎样查看一个工作簿中有几个工作表 有几个EXCEL文件，每个文件（工作簿）中都有上百个工作表， 怎样可以一次性查看一个簿包含几个表？
目前好像没有直接可以看到有多少张工作表的按钮，这就需要运用函数来计算了：
 
在任意一个单元格内输入 
=INFO("numfile")
 单元格属性为 常规
 可以看到打开所有EXCEL文件的工作表数量

 然后回车即可

 

转载于:https://www.cnblogs.com/cymwill/p/7029524.html

本例介绍在excel中如何将一个工作表根据条件拆分成多个工作表。

注意：很多朋友反映sheets(i).delete这句代码出错，要注意下面第一个步骤，要拆分的数据工作表名称为“数据源”，
 而不是你新建工作簿时的sheet1这种。手动改成“数据源”即可。或者是把代码中得"数据源"改为你得源工作表“Sheet1”也行


先展示最后效果：




开始步骤例子：





代码如下

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 <> "Sheet1" Then
             Sheets(i).Delete

        End If

    Next i

    Set d = CreateObject("Scripting.Dictionary")

    Myr = Worksheets("Sheet1").UsedRange.Rows.Count

    Arr = Worksheets("Sheet1").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 [Sheet1$] 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





6.

7.

8.

9.

10



11.

12注意：
1）原始数据表要从第一行开始有数据，并且不能有合并单元格；
2）打开工作簿时需要开启宏，否则将无法运行代码。

 以下是office中的EXCEL，wps会员的话自带拆分功能（特别方便）


	
例如工作薄中有多个工作表，如图：

	

	
	

	
将一个Excel工作簿中的多个工作表(sheet)拆分成如下图所示结果

	

	
	

	
打开需要拆分的excel，在任意工作表右击，点击“查看代码”

	

	
	

	
在打开的窗口中输入如下代码：

	
Private Sub 分拆工作表()

	
       Dim sht As Worksheet

	
       Dim MyBook As Workbook

	
       Set MyBook = ActiveWorkbook

	
       For Each sht In MyBook.Sheets

	
           sht.Copy

	
           ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & sht.Name, FileFormat:=xlOpenXMLWorkbook     '将工作簿另存为xlsx格式

	
           ActiveWorkbook.Close

	
       Next

	
       MsgBox "文件已经被分拆完毕!"

	
   End Sub

	

	
	

	
点击绿色三角，运行程序，等待拆分。

	

	
	

	
拆分成功后，会弹出窗口提示。

	

	
	

	
7

	
返回Excel工作簿文件所在路径 即可查看已经拆分的工作薄。