程式碼示例：

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