按照“样式“工作表模板汇总每个单位的数据

吉仔

急，急，想麻烦帮忙写段VAB代码，是根据认领状态拆分工作表，按照“样式“工作表模板样式，生成的新工作表实现拆分状态及对方单位的汇总和累计合计，谢谢！！！下面是想实现的数据

shiruiqiang

1、是否格式相同，最多11行？还是没有超出？
2、是否在一张表中，还是每个单位一张表？
不说清楚，论坛各位老师写好了可能达不到你的要求

吉仔

各位老师，都是要求格式相同，就是按“样式”的工作表格式，复制拆分按认领状态对应的工作表，例如“未认领”一张工作表，已“认领状态”又一张工作表，每张工作表会将相应的收款对方单位汇总显示出来，并对应生成累计金额，谢谢

吉仔

求助，求助

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Application.DisplayAlerts = False
   
4. For Each sht In Sheets
   
5.     If InStr(sht.Name, "待认领") Then sht.Delete
   
6. Next
   
7. Application.DisplayAlerts = True
   
8. a = [{"待认领","未待认领"}]
   
9. For i = 1 To UBound(a)
   
10.     Set sht = Sheets.Add
    
11.     sht.Name = a(i)
    
12. Next i
    
13. Set dic = CreateObject("scripting.dictionary")
    
14. With Sheet7
    
15. .Select
    
16.     arr = .[b2].CurrentRegion.Value
    
17. End With
    
18.     For i = 4 To UBound(arr)
    
19.         dic(arr(i, 9)) = ""
    
20.     Next
    
21. r = 1: rr = 1
    
22. ReDim brr(1 To UBound(arr), 1 To 8): ReDim crr(1 To UBound(arr), 1 To 8)
    
23. For Each k In dic.keys
    
24.     m = 0: n = 0
    
25.     For i = 4 To UBound(arr)
    
26.        If arr(i, 10) = "待认领" Then
    
27.             If arr(i, 9) = k Then
    
28.                 m = m + 1
    
29.                 For c = 1 To 8
    
30.                     brr(m, c) = arr(i, c + 1)
    
31.                 Next c
    
32.             End If
    
33.         ElseIf arr(i, 10) = "未待认领" Then
    
34.             If arr(i, 9) = k Then
    
35.                 n = n + 1
    
36.                 For c = 1 To 8
    
37.                     crr(n, c) = arr(i, c + 1)
    
38.                 Next c
    
39.             End If
    
40.        End If
    
41.            
    
42.     Next i
    
43.     With Sheet6
    
44.         If m > 0 Then
    
45.         .[c2].Value = "待认领": .[d2].Value = arr(2, 4): .[g2].Value = k
    
46.         .[b4].Resize(10, 8) = ""
    
47.         .[b4].Resize(m, 8) = brr
    
48.         rw = r + Sheets("待认领").Cells(Rows.Count, 1).End(3).Row
    
49.         .Rows("1:14").Copy Sheets("待认领").Range("a" & rw)
    
50.         End If
    
51.         If n > 0 Then
    
52.         .[c2].Value = "未待认领": .[d2].Value = arr(2, 4): .[g2].Value = k
    
53.         .[b4].Resize(10, 8) = ""
    
54.         .[b4].Resize(n, 8) = crr
    
55.         rww = rr + Sheets("未待认领").Cells(Rows.Count, 1).End(3).Row
    
56.         .Rows("1:14").Copy Sheets("未待认领").Range("a" & rww)
    
57.         End If
    
58.     End With
    
59. Next k
    
60. MsgBox "完成！"
    
61. End Sub
    

复制代码

Qs18

试试...........

z865593849

汇总

Qs18

试试..........