這下子明白了，部門都在A列，表頭只有壹行，代碼如下圖：
下面的文字僅供參考，瀏覽器可能會偷吃字符：
Option Explicit
Sub 拆分()
Dim depts, dept, arr, i, j, st, wb, st2
Set depts = CreateObject("scripting.dictionary")
'第壹次掃描，獲得所有部門清單
For Each st In Sheets
arr = st.UsedRange
For i = 2 To UBound(arr)
dept = Trim(arr(i, 1))
If dept <> "" Then depts(dept) = True
Next i
Next st
'第二次掃描，生產各部門文件
Set wb = ThisWorkbook
For Each dept In depts.keys
With Workbooks.Add
For Each st In wb.Sheets
arr = st.UsedRange
Set st2 = .Sheets.Add(after:=.Sheets(.Sheets.Count))
st2.Name = st.Name
j = 0
For i = 1 To UBound(arr)
If i = 1 Or Trim(arr(i, 1)) = dept Then
j = j + 1
st.Rows(i).Copy st2.Rows(j)
End If
Next i
Next st
.SaveAs wb.FullName & "." & dept & ".xlsx"
.Close
End With
Next dept
End Sub