Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 743|回复: 15

[已解决] [已解决]用VBA数组字典进行多条件求和

[复制链接]
发表于 2017-6-19 19:35 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
本帖最后由 laoau138 于 2017-6-20 18:02 编辑

用VBA数组字典进行多条件求和
用VBA数组字典进行多条件求和.png

用VBA数组字典进行多条件求和.rar

7.77 KB, 下载次数: 17

idnoidno发布于 2017-6-19 20:55 |显示全部回帖
  1. Sub test()
  2.     Dim dic As Object
  3.     Dim v
  4.     Dim i As Long, s
  5.      
  6.     Set dic = CreateObject("scripting.dictionary")
  7.      
  8.     v = Range("a1").CurrentRegion.Value
  9.     For i = 2 To UBound(v)
  10.         s = v(i, 1) & vbTab & v(i, 2)
  11.         If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
  12.         dic(s) = Array(v(i, 1), v(i, 2), dic(s)(2) + 1, dic(s)(3) + v(i, 3))
  13.     Next
  14.      
  15.     With Range("F1")
  16.         .CurrentRegion.ClearContents
  17.         .Resize(, 4).Value = [{"產品","規格","次數","總和"}]
  18.         .Offset(1).Resize(dic.Count, 4).Value = _
  19.         Application.Transpose(Application.Transpose(dic.Items))
  20.         .CurrentRegion.Sort key1:=.Columns(1), Header:=xlYes
  21.     End With
  22.      
  23. End Sub


复制代码
发表于 2017-6-19 20:55 | 显示全部楼层    本楼为最佳答案   
  1. Sub test()
  2.     Dim dic As Object
  3.     Dim v
  4.     Dim i As Long, s
  5.      
  6.     Set dic = CreateObject("scripting.dictionary")
  7.      
  8.     v = Range("a1").CurrentRegion.Value
  9.     For i = 2 To UBound(v)
  10.         s = v(i, 1) & vbTab & v(i, 2)
  11.         If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
  12.         dic(s) = Array(v(i, 1), v(i, 2), dic(s)(2) + 1, dic(s)(3) + v(i, 3))
  13.     Next
  14.      
  15.     With Range("F1")
  16.         .CurrentRegion.ClearContents
  17.         .Resize(, 4).Value = [{"產品","規格","次數","總和"}]
  18.         .Offset(1).Resize(dic.Count, 4).Value = _
  19.         Application.Transpose(Application.Transpose(dic.Items))
  20.         .CurrentRegion.Sort key1:=.Columns(1), Header:=xlYes
  21.     End With
  22.      
  23. End Sub


复制代码

评分

参与人数 1经验 +9 收起 理由
laoau138 + 9 来学习

查看全部评分

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-19 21:36 | 显示全部楼层
本帖最后由 laoau138 于 2017-6-19 21:37 编辑

这个还能优化不
回复 支持 反对

使用道具 举报

发表于 2017-6-20 07:58 | 显示全部楼层
您指的優化是什麼
回复 支持 反对

使用道具 举报

发表于 2017-6-20 12:53 | 显示全部楼层
問題沒解決嗎
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-20 13:29 | 显示全部楼层
本帖最后由 laoau138 于 2017-6-20 13:31 编辑

你写的代码不行,怎么H列多出个次数    怎么会出现繁体字


Sub  你看这个写()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    k = 1
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If Not d.exists(t) Then
            k = k + 1
            d(t) = k
            If k <> i Then
                arr(k, 1) = arr(i, 1)
                arr(k, 2) = arr(i, 2)
                arr(k, 3) = arr(i, 3)
            End If
        Else
            arr(d(t), 3) = arr(d(t), 3) + arr(i, 3)
        End If
    Next
    [f1].Resize(k, 3) = arr
End Sub




回复 支持 反对

使用道具 举报

发表于 2017-6-20 16:56 | 显示全部楼层
統計次數你不要嗎,我是台灣人,為了學習所以加入這邊來跟大家一起學習
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-20 17:44 | 显示全部楼层
idnoidno 发表于 2017-6-20 16:56
統計次數你不要嗎,我是台灣人,為了學習所以加入這邊來跟大家一起學習

论坛好厉害,台湾人也进来了,你说"什么语"    难道说“普通话”
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-20 17:45 | 显示全部楼层
idnoidno 发表于 2017-6-20 16:56
統計次數你不要嗎,我是台灣人,為了學習所以加入這邊來跟大家一起學習

遥远的他方,更要顶你了
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-20 17:45 | 显示全部楼层

你的VBA,自学,还是跟某个师傅
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2017-10-20 11:06 , Processed in 0.109200 second(s), 26 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

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