• 按部門拆分為工作簿

Paste_Image.png

操作步驟

• 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

結果

結果1