操作步骤

1、提取部门名称，循环遍历部门新建工作簿。
2、筛选数据，获取可见行，复制到新建的工作簿。
3、关闭新建的工作簿，重命名，并保存数据。
4、重复上面操作，直到循环结束。

1、提取部门名称

  With ThisWorkbook.Sheets("数据源")
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row '本工作簿数据源工作表的最后一行
        Set rng = .Range("a1:b" & lastrow)'数据源放进单元格变量中
        .Range("a2:A" & lastrow).Copy .Range("h1") '将部门数据复制到单元格H1
        .Range("h1:$h" & lastrow).RemoveDuplicates Columns:=1, Header:=xlNo '去重复，提取部门
        lastrow1 = .Cells(Rows.Count, "h").End(xlUp).Row '获取部门的数量
    End With

2 遍历部门，筛选数据，输出到新建的工作簿,关闭并保存。

 For i = 1 To lastrow1 '循环新建工作簿
            sname = .Cells(i, "h") '工作簿名称
            rng.AutoFilter Field:=1, Criteria1:="" & sname '筛选部门数据
            Set rng1 = .Range("A1:B" & lastrow).SpecialCells(xlCellTypeVisible) '获取筛选后的部门数据
            rng.AutoFilter '解除筛选
           Set wkb = Workbooks.Add '新建工作簿
            rng1.Copy wkb.Sheets("sheet1").Range("a1") '输出筛选的数据到目标工作簿
            '另存为以部门命名的新工作簿，存放路径为同一个文件夹的路径（同一个文件夹路径相同）
            wkb.SaveAs Filename:=ThisWorkbook.Path & "\" & sname & ".xlsx"
            wkb.Close '关闭工作簿(另存为，会自动保存更改)
        Next

代码合起来

Sub 拆分工作表为工作簿()
    Dim i As Integer, sname As String
    Dim wkb As Workbook, rng As Range, rng1 As Range
    Dim lastrow As Integer
    Dim lastrow1 As Integer
    Application.ScreenUpdating = False '关闭屏幕刷新
    Application.DisplayAlerts = False '关闭提示
    
    With ThisWorkbook.Sheets("数据源")
'************************提取部门名称***********************************
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row '本工作簿小明工作表的最后一行
        Set rng = .Range("a1:b" & lastrow) '数据源放到单元格变量中
        .Range("a2:A" & lastrow).Copy .Range("h1") '将部门数据复制带单元格H1
        .Range("h1:h" & lastrow).RemoveDuplicates Columns:=1, Header:=xlNo '去重复，提取部门
        lastrow1 = .Cells(Rows.Count, "h").End(xlUp).Row '获取部门的数量

        For i = 1 To lastrow1 '循环新建工作簿
'*******************************筛选部门的数据*************************
            sname = .Cells(i, "h") '工作簿名称
            rng.AutoFilter Field:=1, Criteria1:="" & sname '筛选部门数据
            '获取筛选后的部门数据
            Set rng1 = rng.SpecialCells(xlCellTypeVisible)
            rng.AutoFilter '解除筛选
'***********************新建工作簿输出数据*****************************
            Set wkb = Workbooks.Add '新建工作簿
            rng1.Copy wkb.Sheets("sheet1").Range("a1") '输出筛选的数据到目标工作簿
 '另存为以部门命名的新工作簿，存放路径为同一个文件夹
            wkb.SaveAs Filename:=ThisWorkbook.Path & "\" & sname & ".xlsx"
            wkb.Close '关闭工作簿(另存为，会自动保存更改)
        Next
        .Range("h:h").Clear '删除辅助的部门H列数据
    End With
    
    Application.DisplayAlerts = True '开启提示
    Application.ScreenUpdating = True '开启刷新
End Sub