這是一個常用而且經典的例子：根據內容，把一個工作表中的內容，拆分到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