[已解决]如何用VBA代替SUMPRODUCT函数

fuclot

想用VBA代替SUMPRODUCT筛选求和，最好可以满足筛选条件的增加、减少，见附件E列。
求大神指点，
谢谢！

求助.rar (2.07 KB, 下载次数: 34)

2014-12-19 10:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2014-12-19 14:06

Sub test()
    Dim A, B, d, i&, j%, t$, s&
    A = Sheet1.Range("a1").CurrentRegion
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        '关键字
        t = ""
        For j = 1 To UBound(A, 2) - 1
            t = t & A(i, j) & ","
        Next j
        '统计
        If d.exists(t) Then
            B(d(t), UBound(B, 2)) = B(d(t), UBound(B, 2)) + A(i, UBound(B, 2))
        Else
            s = s + 1
            d(t) = s
            For j = 1 To UBound(B, 2)
                B(s, j) = A(i, j)
            Next j
        End If
    Next i
    Sheet2.Activate
    Range("a1").CurrentRegion = ""
    Range("a1").Resize(1, UBound(A, 2)) = Application.Index(A, 1, 0)
    Range("a2").Resize(UBound(B), UBound(B, 2)) = B
End Sub

求助3 - 副本.rar (10.56 KB, 下载次数: 164)

2014-12-19 14:06 上传

点击文件名下载附件
是这样吗？第14行是5喔

跳转到最佳答案楼层

爱疯

Sub test()
    Dim A, B, d, i&, j%, t$, s&
    A = Sheet1.Range("a1").CurrentRegion
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        '关键字
        t = ""
        For j = 1 To 4
            t = t & A(i, j) & ","
        Next j
        '统计
        If d.exists(t) Then
            B(d(t), UBound(B, 2)) = B(d(t), UBound(B, 2)) + A(i, UBound(B, 2))
        Else
            s = s + 1
            d(t) = s
            For j = 1 To UBound(B, 2)
                B(s, j) = A(i, j)
            Next j
        End If
    Next i
    Sheet2.Activate
    Range("a1").CurrentRegion = ""
    Range("a1").Resize(1, UBound(A, 2)) = Application.Index(A, 1, 0)
    Range("a2").Resize(UBound(B), UBound(B, 2)) = B
End Sub
求助2.rar (10.88 KB, 下载次数: 47)

2014-12-19 11:37 上传

点击文件名下载附件

fuclot

爱疯 发表于 2014-12-19 11:37
Sub test()
    Dim A, B, d, i&, j%, t$, s&
    A = Sheet1.Range("a1").CurrentRegion

谢谢！
能否有办法在插入一列或者多列条件后，仍然使VBA有用。
即，
我在新附件中插入一列F列后，运算结果仍然是没插入F列之前的结果，能否满足在插入新条件后仍保证运算正确？
感激不尽。
求助2 - 副本.rar (10.61 KB, 下载次数: 8)

2014-12-19 13:22 上传

点击文件名下载附件

爱疯

插入F列后，结果哪儿不对？标记一下看看

fuclot

爱疯 发表于 2014-12-19 13:28
插入F列后，结果哪儿不对？标记一下看看

标红区域.rar (10.73 KB, 下载次数: 9)

2014-12-19 13:33 上传

点击文件名下载附件

标红区域，谢谢师傅。

爱疯

不明白为什么g2应该是5，而且还多出了第14行

fuclot

爱疯 发表于 2014-12-19 13:37
不明白为什么g2应该是5，而且还多出了第14行

因为F2单元格是“。”不是“.”

爱疯

Sub test()
    Dim A, B, d, i&, j%, t$, s&
    A = Sheet1.Range("a1").CurrentRegion
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        '关键字
        t = ""
        For j = 1 To UBound(A, 2) - 1
            t = t & A(i, j) & ","
        Next j
        '统计
        If d.exists(t) Then
            B(d(t), UBound(B, 2)) = B(d(t), UBound(B, 2)) + A(i, UBound(B, 2))
        Else
            s = s + 1
            d(t) = s
            For j = 1 To UBound(B, 2)
                B(s, j) = A(i, j)
            Next j
        End If
    Next i
    Sheet2.Activate
    Range("a1").CurrentRegion = ""
    Range("a1").Resize(1, UBound(A, 2)) = Application.Index(A, 1, 0)
    Range("a2").Resize(UBound(B), UBound(B, 2)) = B
End Sub

求助3 - 副本.rar (10.56 KB, 下载次数: 164)

2014-12-19 14:06 上传

点击文件名下载附件
是这样吗？第14行是5喔

fuclot

爱疯 发表于 2014-12-19 14:06
Sub test()
    Dim A, B, d, i&, j%, t$, s&
    A = Sheet1.Range("a1").CurrentRegion

对了！师傅好厉害。
但能不能把14行自动弹出、删除的功能去掉？
因为有时候并不是数据源的所有项都要体现在主表中。。。