如何把人员收入表按公司拆分成独立工作簿，并删除项目为0的栏？求代码。

ylaxsm

如图所示，收入总表上有若干公司，需要以公司名为准，拆分成若干独立工作簿。如果某公司的某项‘收入栏目’全部为空（“0”也视为‘空’），则这个‘收入栏目’都不显示出来。

求代码。

半百

请测试。。。

gwjkkkkk

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()      '//2023.12.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Dim arr, brr, b, d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set fso = CreateObject("Scripting.FileSystemObject")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "拆分后效果"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set sh = ThisWorkbook.Sheets("收入")
    
12.     c = 2     '//拆分列号
    
13.     b = [{1,2,3,4,9}]
    
14.     With sh
    
15.         r = .Cells(.Rows.Count, c).End(xlUp).Row
    
16.         arr = .Range("a1:j" & r)
    
17.     End With
    
18.     For i = 2 To UBound(arr)
    
19.         s = arr(i, c)
    
20.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
21.         d(s)(i) = i
    
22.     Next
    
23.     On Error Resume Next
    
24.     For Each k In d.keys
    
25.         m = 0
    
26.         ReDim brr(1 To UBound(arr), 1 To 5)
    
27.         Application.SheetsInNewWorkbook = 1
    
28.         Set wb = Workbooks.Add
    
29.         With wb.Sheets(1)
    
30.             .Name = k
    
31.             .[a1:e1] = Array("序号", "公司", "姓名", "基薪", "补发")
    
32.             For Each kk In d(k).keys
    
33.                 m = m + 1
    
34.                 brr(m, 1) = m
    
35.                 For j = 2 To UBound(b)
    
36.                     brr(m, j) = arr(kk, b(j))
    
37.                 Next
    
38.             Next
    
39.             .[a2].Resize(m, 5) = brr
    
40.             With .[a1].Resize(m + 1, 5)
    
41.                 .Borders.LineStyle = 1
    
42.                 .HorizontalAlignment = xlCenter
    
43.                 .VerticalAlignment = xlCenter
    
44.                 .EntireColumn.AutoFit
    
45.             End With
    
46.         End With
    
47.         wb.SaveAs p1 & k
    
48.         wb.Close
    
49.     Next
    
50.     Set d = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
53. End Sub
    

复制代码

ykcbf1100

参与一下，字典嵌套。