excel中将一张表中数据拆分成多个工作表，按部门不相同的拆分成单个工作表，且单个工作表名及为部门

在工作表名称上点右键选查看代码,粘贴以下代码到弹出窗口.关闭弹出窗口 ALT+F8选中该宏执行

Sub 拆分工作表()
Application.ScreenUpdating = False
Dim rng As Range, arr()
endrow = Range("A65536").End(xlUp).Row
ReDim arr(2, 0)
arr(0, 0) = Range("A2").Value
arr(1, 0) = Range("A2").Row
arr(2, 0) = Range("A2").Row
L = 0
For i = 2 To endrow
temp = Range("A" & i).Value
For ii = i + 1 To endrow
With Range("A" & ii)
If .Value = temp Then
arr(2, L) = .Row
Else
L = L + 1
ReDim Preserve arr(2, L)
arr(0, L) = .Value
arr(1, L) = .Row
arr(2, L) = .Row
i = .Row - 1
Exit For
End If
End With
Next
Next
For i = 0 To L
Workbooks.Add
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & arr(0, i)
ActiveSheet.Name = arr(0, i)
ActiveSheet.Range("A:C").ColumnWidth = 10
ActiveSheet.Range("A:C").HorizontalAlignment = xlCenter
ActiveSheet.Range("A:C").VerticalAlignment = xlCenter
ActiveSheet.Range("C:C").NumberFormatLocal = "m-d"
ActiveSheet.Range("D:D").ColumnWidth = 30
ThisWorkbook.Activate
Workbooks(arr(0, i) & ".xls").Sheets(1).Rows(1).Value = Sheet1.Rows(1).Value
For bc = arr(1, i) To arr(2, i)
Workbooks(arr(0, i) & ".xls").Sheets(1).Rows(bc - arr(1, i) + 2).Value = Sheet1.Rows(bc).Value
Next
Workbooks(arr(0, i) & ".xls").Close SaveChanges:=True
Next
Application.ScreenUpdating = True
MsgBox "拆分工作表完成!" & vbCrLf & "在当前工作薄路径下创建工作薄:" & L + 1 & "个."
End Sub