VBA代码实例---一个工作表拆分为N个工作表

这是一个常用而且经典的例子：根据内容，把一个工作表中的内容，拆分到N个工作表中，并根据内容命名新建的工作表。

¤主要知识点¤

1、影响代码执行闪屏以及提示框的处理：

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True

2、工作表的新建，命名，删除操作；

3、单元格区域的内容复制方式；

4、IF分支语句和For循环语句的使用；

 ¤实例¤

新建工作表，把员工信息复制到对应的以部门命名的工作表中。

¤实现代码¤ 

Option Explicit

Sub 拆分工作表()

    Application.DisplayAlerts = False  '不显示错误提示框
    Application.ScreenUpdating = False  '不闪屏
    
    Dim i As Integer   '辅助工作表变量
    Dim sh As Worksheet
    
    '删除多余的工作表
    If Sheets.Count > 1 Then
        For i = Worksheets.Count To 2 Step -1
            Worksheets(i).Delete
        Next i
    End If
    
    '对信息表中数据按照部门排序，之后按照部门拆分进新的工作表
    Dim irow As Integer '定义一共需要处理的行号
    Dim istart As Integer  '定位起始行数变量
    
    irow = Range("A" & Rows.Count).End(xlUp).Row  '计算一共需要处理的行号
    If irow > 2 Then
    
        Range("a3:H" & irow).Sort Range("f2"), xlAscending  '对信息区域进行排序，不能含标题
        istart = 3
        For i = 3 To irow
            With Worksheets("员工信息表")  '指定活动工作表
            
            If .Range("f" & i).Value <> .Range("f" & i + 1).Value Then   '判断是否为同一部门
            
                Worksheets.Add after:=Worksheets(Sheets.Count)  '新建工作表
                Set sh = Worksheets(Worksheets.Count) '指定工作表给变量
                sh.Name = .Range("f" & i).Value  '以部门命名工作表
                .Range("a1:h2").Copy sh.Range("a1:h2") '复制标题到新建工作表中
                .Range("a" & istart & ":h" & i).Copy sh.Range("a3") '复制内容到工作表中
                sh.Columns.AutoFit  '设置自动列宽
                
                istart = i + 1
            End If
            End With
        Next i
    
    End If
    
    Worksheets("员工信息表").Select  '回到第一个工作表
    
    Application.ScreenUpdating = True  '恢复闪屏默认设置
    Application.DisplayAlerts = True   '恢复提示框默认设置

End Sub

Option Explicit

Sub 拆分工作表2()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim i As Integer
    
    If Worksheets.Count > 1 Then
        For i = Worksheets.Count To 2 Step -1
            Worksheets(i).Delete
        Next i
    End If
    
    Dim irow As Integer
    Dim k As Integer
    Dim sDep As String
    Dim sh As Worksheet
    
    irow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To irow
        
        sDep = Worksheets(1).Range("F" & i).Value
        On Error Resume Next             '遇到错误继续，这里错误主要是未定义的工作表
        Set sh = Worksheets(sDep)      '这一行如果遇到工作表不存在，就会报错，返回值为err.number <> 0
        If Err.Number <> 0 Then           '工作表不存在，那么新建工作表，并把标题复制到新建的工作表
            Set sh = Worksheets.Add(, Worksheets(1))
            sh.Name = sDep
            Worksheets(1).Range("A1:h2").Copy sh.Range("A1")
        End If
        
        k = sh.Range("A1").CurrentRegion.Rows.Count + 1   '依次复制内容到工作表的行号
        'sh.Range("A" & k).Resize(1, 7).Value = Worksheets(1).Range("A" & i).Resize(1, 7).Value   '赋值方法
        
        Worksheets(1).Range("A" & i & ":h" & i).Copy sh.Range("A" & k)    '复制方法
        sh.Columns.AutoFit                                '列宽自动调整
        
    Next i
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub