求各位前辈帮忙,多列字典汇总

feilanga

如何用字典筛选出透视表的效果

金额按客户分类汇总   余额为0不显示

生成到汇总查询表中

返利按供应商汇总 多列汇总模拟数据.rar (75.86 KB, 下载次数: 18)

2019-2-19 16:25 上传

点击文件名下载附件

先谢谢各位前辈帮助. 自己很长时间里也找了一些VBA代码 试图套用一下 ,然而却总是遇到各种问题,困扰了2个月了.求助

feilanga

如图所示数据   ,求帮忙!

chaohuahch

这个应该是字典的，最基本的用法。

feilanga

chaohuahch 发表于 2019-2-19 16:36
这个应该是字典的，最基本的用法。

然而我找了10几个字典写法 却一塌糊涂  

feilanga

chaohuahch 发表于 2019-2-19 16:36
这个应该是字典的，最基本的用法。

Sub 字典汇总方法4()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion '数据装入数组
    For i = 1 To UBound(arr)
        If arr(i, 1) <> " " Then '条件
            If d.Exists(arr(i, 1)) Then '字典里存在的时候
                brr = d(arr(i, 1))
                brr(2) = brr(2) + arr(i, 2) '要汇总的列
                brr(4) = brr(4) + arr(i, 4) '要汇总的列
            Else
                ReDim brr(1 To UBound(arr, 2)) '声明动态数组 装符合条件的每列数据
                For j = 1 To UBound(arr, 2): brr(j) = arr(i, j): Next '符合条件的列循环生成数组集合
            End If
            d(arr(i, 1)) = brr '更新字典条目中的值
        End If
    Next
    If d.Count Then
        Range("f1").CurrentRegion.ClearContents '清除结果区的数据 除外标题行外
        brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.items)) '数组装置
        Range("f1").Resize(d.Count, UBound(arr, 2)) = brr '赋值
    Else
        MsgBox "无符合条件的数据"
    End If
End Sub

例如这一个代码  数据源有4列 汇总结果也有4列  如果我只汇总2列呢 怎么改呢

cunfu2010

feilanga 发表于 2019-2-19 16:46
Sub 字典汇总方法4()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")

Sub test()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet4.Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 9)) = d(arr(i, 9)) + arr(i, 17)
    Next
    Sheet2.Range("f1").Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.items))
End Sub

乐乐2006201505

Sub 提取条件指定单列数据()
    Dim arr, brr, Myr&, Myr2&, i&, s As String
    Set d = CreateObject("scripting.dictionary")
    With Sheets(1)
        arr = .Range("a1").CurrentRegion '数据装入数组'.Range("J5:O" & Myr)
        For i = 2 To UBound(arr)
            s = arr(i, 9)
            d(s) = d(s) + arr(i, 17)
        Next
    End With
    k = d.keys: t = d.items
    With Sheets(4)
        ReDim brr(1 To d.Count, 1 To 2)
            For i = 1 To UBound(brr)
                brr(i, 1) = k(i - 1)
                brr(i, 2) = t(i - 1)
            Next
        .[e8].Resize(, 2) = Array("供应商", "返利")
        .[e9].Resize(UBound(brr), UBound(brr, 2)).ClearContents
        .[e9].Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
    Erase arr, brr
End Sub

feilanga

乐乐2006201505 发表于 2019-2-19 22:17
Sub 提取条件指定单列数据()
    Dim arr, brr, Myr&, Myr2&, i&, s As String
    Set d = CreateObject ...

非常感谢您的用心回复。帮助很大。我慢慢理解学习一下。

feilanga

cunfu2010 发表于 2019-2-19 17:17
Sub test()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")

谢谢了，学习一下

feilanga

乐乐2006201505 发表于 2019-2-19 22:17
Sub 提取条件指定单列数据()
    Dim arr, brr, Myr&, Myr2&, i&, s As String
    Set d = CreateObject ...

测试了一下，您解决的是第二个问题。而第一个问题才是最重要的。就是透视表1的效果   如果要达到这样的效果，代码如何书写，还有，可以做到余额为0不显示吗