Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2313|回复: 5

[已解决]求助高人修改代码

[复制链接]
发表于 2016-4-10 14:19 | 显示全部楼层 |阅读模式
修改一、将以《会员缴费表》A1查询汇总修改为H1查询汇总。
修改二、将保存到《Sheet1》的内容E到A之间的空单元格合并。
修改三、在最后一行增加总计。

Sub 推荐人汇总()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 9)
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr) - 0
    x = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 7) & "," & arr(i, 8) & "," & arr(i, 9)
    If Not d.exists(x) Then
        n = n + 1: d(x) = n
        brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2)
        brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4)
        brr(n, 5) = arr(i, 5): brr(n, 6) = arr(i, 6)
        brr(n, 7) = arr(i, 7): brr(n, 8) = arr(i, 8)
        brr(n, 9) = arr(i, 9)
    End If
    p = d(x)
    brr(p, 5) = brr(p, 5) + arr(i, 5)
Next
With Sheet1
    .Cells.Clear
    .[a1].Resize(1, 9) = Array("推荐人", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "编号", "交款日期")
    .[a2].Resize(n, 9) = brr
    .[a2].Resize(n, 9).Sort key1:=.[a2], key2:=.[b2], key3:=.[c2]
    arr = .[a2].Resize(n + 1, 9)
    ReDim brr(1 To UBound(arr) + 100, 1 To 9)
    n = 0
    For i = 1 To UBound(arr) - 1
        n = n + 1
        For J = 1 To 9: brr(n, J) = arr(i, J): Next
            s1 = s1 + arr(i, 5)
            If arr(i, 1) <> arr(i + 1, 1) Then
                n = n + 1
                brr(n, 1) = arr(i, 1) & "总计"
                brr(n, 5) = s1
                s1 = 0
            End If
        Next
        .[a2].Resize(n, 9) = brr
        .Activate
    End With
End Sub


最佳答案
2016-4-11 14:49
改写一下代码。
  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 Sheet1
  37.         .Cells.Clear
  38.         .[a1].Resize(1, 9) = Array("推荐人", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "编号", "交款日期")
  39.         .[a2].Resize(n, 9) = brr
  40.         For i = 1 To n
  41.             If brr(i, 1) Like "*总计" Then .Cells(i + 1, 1).Resize(1, 4).Merge
  42.         Next
  43.         .Activate
  44.     End With
  45. End Sub
复制代码

分类汇总.rar

25.91 KB, 下载次数: 16

发表于 2016-4-11 14:20 | 显示全部楼层
  1. Sub 推荐人汇总()
  2.     arr = [a1].CurrentRegion
  3.     ReDim brr(1 To UBound(arr), 1 To 9)
  4.     Set d = CreateObject("scripting.dictionary")
  5.     For i = 2 To UBound(arr) - 0
  6.         x = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 7) & "," & arr(i, 8) & "," & arr(i, 9)
  7.         If Not d.exists(x) Then
  8.             n = n + 1: d(x) = n
  9.             For j = 1 To 9
  10.                 brr(n, j) = arr(i, j)
  11.             Next
  12.         End If
  13.         p = d(x)
  14.         brr(p, 5) = brr(p, 5) + arr(i, 5)
  15.     Next
  16.     Application.DisplayAlerts = False
  17.     With Sheet1
  18.         .Cells.Clear
  19.         .[a1].Resize(1, 9) = Array("推荐人", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "编号", "交款日期")
  20.         .[a2].Resize(n, 9) = brr
  21.         .[a2].Resize(n, 9).Sort key1:=.[h2], key2:=.[a2], key3:=.[b2]
  22.         arr = .[a2].Resize(n + 1, 9)
  23.         ReDim brr(1 To UBound(arr) + 100, 1 To 9)
  24.         n = 0
  25.         For i = 1 To UBound(arr) - 1
  26.             n = n + 1
  27.             For j = 1 To 9: brr(n, j) = arr(i, j): Next
  28.                 s1 = s1 + arr(i, 5)
  29.                 s = s + arr(i, 5)
  30.                 If arr(i, 8) <> arr(i + 1, 8) Then
  31.                     n = n + 1
  32.                     brr(n, 1) = arr(i, 8) & "总计"
  33.                     .Cells(n + 1, 1).Resize(1, 4).Merge
  34.                     brr(n, 5) = s1
  35.                     s1 = 0
  36.                 End If
  37.         Next
  38.         n = n + 1
  39.         brr(n, 1) = "总计": brr(n, 5) = s
  40.         .Cells(n + 1, 1).Resize(1, 4).Merge
  41.         .[a2].Resize(n, 9) = brr
  42.         .Activate
  43.     End With
  44.     Application.DisplayAlerts = True
  45. End Sub
复制代码
回复

使用道具 举报

发表于 2016-4-11 14:49 | 显示全部楼层    本楼为最佳答案   
改写一下代码。
  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 Sheet1
  37.         .Cells.Clear
  38.         .[a1].Resize(1, 9) = Array("推荐人", "会员形式", "姓名", "性别", "金额", "联系方式", "备注", "编号", "交款日期")
  39.         .[a2].Resize(n, 9) = brr
  40.         For i = 1 To n
  41.             If brr(i, 1) Like "*总计" Then .Cells(i + 1, 1).Resize(1, 4).Merge
  42.         Next
  43.         .Activate
  44.     End With
  45. End Sub
复制代码
回复

使用道具 举报

发表于 2016-4-11 14:53 | 显示全部楼层
1楼、2楼的代码的金额均多算了一遍。3楼的是对的。

分类汇总.rar

26.83 KB, 下载次数: 14

回复

使用道具 举报

 楼主| 发表于 2016-4-11 21:17 | 显示全部楼层
grf1973 发表于 2016-4-11 14:49
改写一下代码。

谢谢老师指点
回复

使用道具 举报

 楼主| 发表于 2016-4-11 21:43 | 显示全部楼层
三楼还增加了注解,太好了,再次感谢!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 18:56 , Processed in 0.719378 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表