- 按部門拆分為工作簿
Paste_Image.png
操作步驟
- 1抖甘、提取部門名稱，循環(huán)遍歷部門新建工作簿葫慎。
- 2衔彻、篩選數(shù)據(jù)薇宠，獲取可見(jiàn)行，復(fù)制到新建的工作簿艰额。
- 3澄港、關(guān)閉新建的工作簿，重命名柄沮，并保存數(shù)據(jù)回梧。
- 4、重復(fù)上面操作祖搓，直到循環(huán)結(jié)束狱意。
- 1、提取部門名稱
With ThisWorkbook.Sheets("數(shù)據(jù)源")
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row '本工作簿數(shù)據(jù)源工作表的最后一行
Set rng = .Range("a1:b" & lastrow)'數(shù)據(jù)源放進(jìn)單元格變量中
.Range("a2:A" & lastrow).Copy .Range("h1") '將部門數(shù)據(jù)復(fù)制到單元格H1
.Range("h1:$h" & lastrow).RemoveDuplicates Columns:=1, Header:=xlNo '去重復(fù)棕硫，提取部門
lastrow1 = .Cells(Rows.Count, "h").End(xlUp).Row '獲取部門的數(shù)量
End With
- 2 遍歷部門髓涯，篩選數(shù)據(jù)，輸出到新建的工作簿,關(guān)閉并保存哈扮。
For i = 1 To lastrow1 '循環(huán)新建工作簿
sname = .Cells(i, "h") '工作簿名稱
rng.AutoFilter Field:=1, Criteria1:="" & sname '篩選部門數(shù)據(jù)
Set rng1 = .Range("A1:B" & lastrow).SpecialCells(xlCellTypeVisible) '獲取篩選后的部門數(shù)據(jù)
rng.AutoFilter '解除篩選
Set wkb = Workbooks.Add '新建工作簿
rng1.Copy wkb.Sheets("sheet1").Range("a1") '輸出篩選的數(shù)據(jù)到目標(biāo)工作簿
'另存為以部門命名的新工作簿纬纪，存放路徑為同一個(gè)文件夾的路徑（同一個(gè)文件夾路徑相同）
wkb.SaveAs Filename:=ThisWorkbook.Path & "\" & sname & ".xlsx"
wkb.Close '關(guān)閉工作簿(另存為，會(huì)自動(dòng)保存更改)
Next
代碼合起來(lái)
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 '關(guān)閉屏幕刷新
Application.DisplayAlerts = False '關(guān)閉提示
With ThisWorkbook.Sheets("數(shù)據(jù)源")
'************************提取部門名稱***********************************
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row '本工作簿小明工作表的最后一行
Set rng = .Range("a1:b" & lastrow) '數(shù)據(jù)源放到單元格變量中
.Range("a2:A" & lastrow).Copy .Range("h1") '將部門數(shù)據(jù)復(fù)制帶單元格H1
.Range("h1:h" & lastrow).RemoveDuplicates Columns:=1, Header:=xlNo '去重復(fù)滑肉，提取部門
lastrow1 = .Cells(Rows.Count, "h").End(xlUp).Row '獲取部門的數(shù)量
For i = 1 To lastrow1 '循環(huán)新建工作簿
'*******************************篩選部門的數(shù)據(jù)*************************
sname = .Cells(i, "h") '工作簿名稱
rng.AutoFilter Field:=1, Criteria1:="" & sname '篩選部門數(shù)據(jù)
'獲取篩選后的部門數(shù)據(jù)
Set rng1 = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter '解除篩選
'***********************新建工作簿輸出數(shù)據(jù)*****************************
Set wkb = Workbooks.Add '新建工作簿
rng1.Copy wkb.Sheets("sheet1").Range("a1") '輸出篩選的數(shù)據(jù)到目標(biāo)工作簿
'另存為以部門命名的新工作簿包各，存放路徑為同一個(gè)文件夾
wkb.SaveAs Filename:=ThisWorkbook.Path & "\" & sname & ".xlsx"
wkb.Close '關(guān)閉工作簿(另存為，會(huì)自動(dòng)保存更改)
Next
.Range("h:h").Clear '刪除輔助的部門H列數(shù)據(jù)
End With
Application.DisplayAlerts = True '開啟提示
Application.ScreenUpdating = True '開啟刷新
End Sub
結(jié)果
結(jié)果1
