[已解决]分类汇总

lufabao

请高人帮忙修改代码
1、将《会员缴费表》查询修改为《会员缴费表2》，查询结果保存到Snrrt3
2、将汇总结果行以红色显示


Private Sub CommandButton1_Click()
    With Sheets("会员缴费表")
        r = .[a65536].End(3).Row
        org = .Range("a1:i" & r)  '原数组
        Application.EnableEvents = False
        .[a2].Resize(r - 1, 9).Sort key1:=.[h2], key2:=.[a2], key3:=.[b2]     '按H列排序
        arr = .Range("a1:i" & r + 1)    '读入数组（加一行，避免最后一行比较时出错）
        .Range("a1:i" & r) = org     '恢复原序
        Application.EnableEvents = True
        ReDim brr(1 To UBound(arr) + 100, 1 To 9)
        Set d = CreateObject("scripting.dictionary")
        For i = 2 To r
            x = Join(Application.Index(arr, i), ",")  '每行各列相连为key
            If Not d.exists(x) Then
                n = n + 1: d(x) = n
                For j = 1 To 9
                    brr(n, j) = arr(i, j)
                Next
            Else
                p = d(x)
                brr(p, 5) = brr(p, 5) + arr(i, 5)
            End If
            s1 = s1 + arr(i, 5)
            If arr(i, 8) <> arr(i + 1, 8) Then
                n = n + 1
                s = s + s1
                brr(n, 1) = arr(i, 8) & "总计"
                brr(n, 5) = s1
                s1 = 0
            End If
        Next
        n = n + 1
        brr(n, 1) = "总计": brr(n, 5) = s
    End With
   
    With Sheet1
        .Cells.Clear
        .[a1].Resize(1, 9) = Array("推荐人", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "编号", "交款日期")
        .[a2].Resize(n, 9) = brr
        For i = 1 To n
            If brr(i, 1) Like "*总计" Then .Cells(i + 1, 1).Resize(1, 4).Merge
        Next
        .Activate
    End With
End Sub

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-15 14:03

1. Sub 推荐人汇总()
   
2.     With Sheets("会员缴费表")
   
3.         r = .[a65536].End(3).Row
   
4.         org = .Range("a1:i" & r)  '原数组
   
5.         Application.EnableEvents = False
   
6.         .[a2].Resize(r - 1, 9).Sort key1:=.[h2], key2:=.[a2], key3:=.[b2]     '按H列排序
   
7.         arr = .Range("a1:i" & r + 1)    '读入数组（加一行，避免最后一行比较时出错）
   
8.         .Range("a1:i" & r) = org     '恢复原序
   
9.         Application.EnableEvents = True
   
10.         ReDim brr(1 To UBound(arr) + 100, 1 To 9)
    
11.         Set d = CreateObject("scripting.dictionary")
    
12.         For i = 2 To r
    
13.             x = Join(Application.Index(arr, i), ",")  '每行各列相连为key
    
14.             If Not d.exists(x) Then
    
15.                 n = n + 1: d(x) = n
    
16.                 For j = 1 To 9
    
17.                     brr(n, j) = arr(i, j)
    
18.                 Next
    
19.             Else
    
20.                 p = d(x)
    
21.                 brr(p, 5) = brr(p, 5) + arr(i, 5)
    
22.             End If
    
23.             s1 = s1 + arr(i, 5)
    
24.             If arr(i, 8) <> arr(i + 1, 8) Then
    
25.                 n = n + 1
    
26.                 s = s + s1
    
27.                 brr(n, 1) = arr(i, 8) & "总计"
    
28.                 brr(n, 5) = s1
    
29.                 s1 = 0
    
30.             End If
    
31.         Next
    
32.         n = n + 1
    
33.         brr(n, 1) = "总计": brr(n, 5) = s
    
34.     End With
    
35.    
    
36.     With Sheets("会员缴费表2")
    
37.         .[c3,d3,h3] = ""
    
38.         .[a5:i1000].Clear
    
39.         .[a5].Resize(n, 9) = brr
    
40.         For i = 1 To n
    
41.             If brr(i, 1) Like "*总计" Then
    
42.                 tjrs = tjrs + 1     '推荐人数
    
43.                 .Cells(i + 4, 1).Resize(1, 4).Merge
    
44.                 .Cells(i + 4, 1).Resize(1, 5).Font.Bold = True
    
45.             End If
    
46.         Next
    
47.         .Cells(n + 4, 1).Resize(1, 5).Font.Color = vbRed
    
48.         .[a5].Resize(n, 9).Borders.LineStyle = 1
    
49.         .[c3] = d.Count: .[d3] = s: .[H3] = tjrs - 1
    
50.         .Activate
    
51.     End With
    
52. End Sub
    

复制代码

跳转到最佳答案楼层

lufabao

请老师们帮忙解决问题，谢谢了，

grf1973

1. Sub 推荐人汇总()
   
2.     With Sheets("会员缴费表")
   
3.         r = .[a65536].End(3).Row
   
4.         org = .Range("a1:i" & r)  '原数组
   
5.         Application.EnableEvents = False
   
6.         .[a2].Resize(r - 1, 9).Sort key1:=.[h2], key2:=.[a2], key3:=.[b2]     '按H列排序
   
7.         arr = .Range("a1:i" & r + 1)    '读入数组（加一行，避免最后一行比较时出错）
   
8.         .Range("a1:i" & r) = org     '恢复原序
   
9.         Application.EnableEvents = True
   
10.         ReDim brr(1 To UBound(arr) + 100, 1 To 9)
    
11.         Set d = CreateObject("scripting.dictionary")
    
12.         For i = 2 To r
    
13.             x = Join(Application.Index(arr, i), ",")  '每行各列相连为key
    
14.             If Not d.exists(x) Then
    
15.                 n = n + 1: d(x) = n
    
16.                 For j = 1 To 9
    
17.                     brr(n, j) = arr(i, j)
    
18.                 Next
    
19.             Else
    
20.                 p = d(x)
    
21.                 brr(p, 5) = brr(p, 5) + arr(i, 5)
    
22.             End If
    
23.             s1 = s1 + arr(i, 5)
    
24.             If arr(i, 8) <> arr(i + 1, 8) Then
    
25.                 n = n + 1
    
26.                 s = s + s1
    
27.                 brr(n, 1) = arr(i, 8) & "总计"
    
28.                 brr(n, 5) = s1
    
29.                 s1 = 0
    
30.             End If
    
31.         Next
    
32.         n = n + 1
    
33.         brr(n, 1) = "总计": brr(n, 5) = s
    
34.     End With
    
35.    
    
36.     With Sheets("会员缴费表2")
    
37.         .[c3,d3,h3] = ""
    
38.         .[a5:i1000].Clear
    
39.         .[a5].Resize(n, 9) = brr
    
40.         For i = 1 To n
    
41.             If brr(i, 1) Like "*总计" Then
    
42.                 tjrs = tjrs + 1     '推荐人数
    
43.                 .Cells(i + 4, 1).Resize(1, 4).Merge
    
44.                 .Cells(i + 4, 1).Resize(1, 5).Font.Bold = True
    
45.             End If
    
46.         Next
    
47.         .Cells(n + 4, 1).Resize(1, 5).Font.Color = vbRed
    
48.         .[a5].Resize(n, 9).Borders.LineStyle = 1
    
49.         .[c3] = d.Count: .[d3] = s: .[H3] = tjrs - 1
    
50.         .Activate
    
51.     End With
    
52. End Sub
    

复制代码

lufabao

grf1973 发表于 2016-4-15 14:03

老师 先感谢帮我加了单元格线和人数统计

另下午的问题没描述清楚  如图

用 红圈 “会员缴费表2” 的内容  保存到绿圈“Sheet3” 中  
“会员缴费表2”   乱线划掉的  2 ，3 行删掉不要  发表的时候忘记修改了

grf1973

1.     With Sheets("会员缴费表")
   
2.         r = .[a65536].End(3).Row
   
3.         org = .Range("a1:i" & r)  '原数组
   
4.         Application.EnableEvents = False
   
5.         .[a2].Resize(r - 1, 9).Sort key1:=.[h2], key2:=.[a2], key3:=.[b2]     '按H列排序
   
6.         arr = .Range("a1:i" & r + 1)    '读入数组（加一行，避免最后一行比较时出错）
   
7.         .Range("a1:i" & r) = org     '恢复原序
   
8.         Application.EnableEvents = True
   
9.         ReDim brr(1 To UBound(arr) + 100, 1 To 9)
   
10.         Set d = CreateObject("scripting.dictionary")
    
11.         For i = 2 To r
    
12.             x = Join(Application.Index(arr, i), ",")  '每行各列相连为key
    
13.             If Not d.exists(x) Then
    
14.                 n = n + 1: d(x) = n
    
15.                 For j = 1 To 9
    
16.                     brr(n, j) = arr(i, j)
    
17.                 Next
    
18.             Else
    
19.                 p = d(x)
    
20.                 brr(p, 5) = brr(p, 5) + arr(i, 5)
    
21.             End If
    
22.             s1 = s1 + arr(i, 5)
    
23.             If arr(i, 8) <> arr(i + 1, 8) Then
    
24.                 n = n + 1
    
25.                 s = s + s1
    
26.                 brr(n, 1) = arr(i, 8) & "总计"
    
27.                 brr(n, 5) = s1
    
28.                 s1 = 0
    
29.             End If
    
30.         Next
    
31.         n = n + 1
    
32.         brr(n, 1) = "总计": brr(n, 5) = s
    
33.     End With
    
34.    
    
35.     Worksheets.Add after:=Sheets(Sheets.Count)       '新建工作表
    
36.     With ActiveSheet
    
37.         .[a1] = "会员缴费明细表": .[a1].Resize(1, 9).Merge     '第一行标题
    
38.         .[a1].Resize(1, 9).Font.Size = 24
    
39.         .[a2].Resize(1, 9) = Array("编号", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "推荐人", "交款日期")     '第二行表头
    
40.         .[a2].Resize(1, 9).Font.Bold = True
    
41.         .[a1].Resize(2, 9).HorizontalAlignment = xlCenter
    
42.         .[a3].Resize(n, 9) = brr      '填充数据
    
43.         For i = 1 To n
    
44.             If brr(i, 1) Like "*总计" Then
    
45.                 tjrs = tjrs + 1     '推荐人数
    
46.                 .Cells(i + 2, 1).Resize(1, 4).Merge
    
47.                 .Cells(i + 2, 1).Resize(1, 5).Font.Bold = True
    
48.             End If
    
49.         Next
    
50.         .Cells(n + 2, 1).Resize(1, 5).Font.Color = vbRed
    
51.         .[a2].Resize(n + 1, 9).Borders.LineStyle = 1
    
52.         .Columns.AutoFit
    
53.         .Activate
    
54.     End With
    
55. End Sub

复制代码