拆分工作簿，将集团工资sheet表拆分为下属公司命名工作簿

18247158266

本人vba菜鸟，希望学习下采用vba简单编程，可以提升下效率，毕竟月底结账不是一个EXCEL表。
需将人力的工资表下发给各下属公司做帐使用，因工资保密需要拆分。数据如链接所示。将工资总表拆分为以下属机构命名工作薄。感谢各位大神。望不吝赐教。

lsc900707

站内搜索“按列拆分工作簿”参考。

dsmch

1. Sub 宏1()
   
2. Application.DisplayAlerts = False
   
3. mypath = ThisWorkbook.Path & ""
   
4. Set sht = ThisWorkbook.Sheets(1)
   
5. For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
   
6.     If sht.Cells(i, 1) Like "*工资汇总表" Then
   
7.         With Workbooks.Add
   
8.             sht.Cells(i, 1).CurrentRegion.Copy .Sheets(1).[a1]
   
9.             sh = sht.Cells(i + 1, 3)
   
10.             .Sheets(1).Name = sh
    
11.             .SaveAs Filename:=mypath & sh & ".xls"
    
12.             .Close True
    
13.         End With
    
14.     End If
    
15. Next
    
16. Application.DisplayAlerts = True
    
17. End Sub

复制代码

liulang0808

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ActiveSheet
   
4.     Sheets.Add after:=Sheets(1)
   
5.     For J = 1 To sh.Cells(Rows.Count, 1).End(3).Row
   
6.         If InStr(sh.Cells(J, 1), "机构名称:") > 0 Then
   
7.             Sheets(2).UsedRange.Clear
   
8.             sh.Cells(J, 1).CurrentRegion.Copy Sheets(2).[a1]
   
9.             Sheets(2).Name = sh.Cells(J, 3)
   
10.             Sheets(2).Copy
    
11.             With ActiveWorkbook
    
12.                 .SaveAs ThisWorkbook.Path & "" & sh.Cells(J, 3) & ".xlsx"
    
13.                 .Close False
    
14.             End With
    
15.         End If
    
16.     Next J
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

liulang0808

附件内容供参考

18247158266

liulang0808 发表于 2018-1-22 20:01
附件内容供参考

拜谢 不胜感激

18247158266

dsmch 发表于 2018-1-22 19:54

可以使用  拜谢

18247158266

不会送花 后期补发