[已解决]多表汇总求和公式求修正

icenotcool

爱疯 发表于 2015-12-23 15:34
建议一个帖子里，只有一个主要问题，以便看帖。

爱疯老师，就是按19楼来回复

爱疯

在对于第1个表（汇总）里

1）在A1:O22里，你把
已提供数据，填充为绿色
需统计区域，填充为黄色

2）D1:O1的内容，能改动吗？

3）已提供数据，是你手动给出的，还是根据什么得到的？

icenotcool

爱疯 发表于 2015-12-23 15:49
在对于第1个表（汇总）里

1）在A1:O22里，你把

解释：A1:B22是已经提供的，D2:O22是自动从每个表的R列对应复制过来的，然后C列是根据D2:O22相加得出来的

2）D1:O1的内容，能改动吗？

爱疯

icenotcool 发表于 2015-12-23 16:00
解释：A1:B22是已经提供的，D2:O22是自动从每个表的R列对应复制过来的，然后C列是根据D2:O22相加得出来的 ...

Sub test()
    Dim d, A, k, i, j, m
    Set d = CreateObject("scripting.dictionary")
    Call test2

    '1）统计
    For k = 2 To Sheets.Count
        With Sheets(k)
            m = "|" & .Name & "|"
            A = .Range("a1:r" & .Range("a65536").End(3).Row)
        End With

        For i = 2 To UBound(A)
            If Not d.exists(A(i, 1)) Then Set d(A(i, 1)) = CreateObject("scripting.dictionary")
            For j = 3 To UBound(A, 2) - 1
                d(A(i, 1))(A(i, 1)) = A(i, 2)    '姓名
                If VBA.IsNumeric(A(i, j)) Then d(A(i, 1))(m) = d(A(i, 1))(m) + A(i, j)   '合计
            Next j
        Next i
    Next k

    '2）查询
    A = Sheets(1).Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        A(i, 2) = d(A(i, 1))(A(i, 1))
        k = 0
        For j = 4 To UBound(A, 2)
            A(i, j) = d(A(i, 1))(A(1, j))
            k = k + A(i, j)
        Next j
        A(i, 3) = k
    Next i

    '3）输出
    Sheets(1).Range("a1").Resize(i - 1, UBound(A, 2)) = A

End Sub

Sub test2()
    Dim n, A, i
    n = Sheets.Count
    ReDim A(1 To 1, 1 To n - 1)
    For i = 2 To n
        A(1, i - 1) = "|" & Sheets(i).Name & "|"
    Next i
    Sheets(1).Range("d1").Resize(1, UBound(A, 2)) = A
End Sub

例子修改2.rar (116.96 KB, 下载次数: 10)

2015-12-23 17:13 上传

点击文件名下载附件




说明：对于19楼附件，需统计分表最后1列就删掉粉色的“-1”，不需则不改。

tgydslr

C2=SUM(SUMIF(INDIRECT(INDEX(MZ,N(IF(1,ROW($2:$8))))&"!B:B"),B2,INDIRECT(INDEX(MZ,N(IF(1,ROW($2:$8))))&"!R:R")))三键下拉
其中MZ=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND("]",GET.WORKBOOK(1)))

tgydslr

例子更新.rar (115.49 KB, 下载次数: 5)

2015-12-23 18:33 上传

点击文件名下载附件

icenotcool

爱疯 发表于 2015-12-23 17:17
Sub test()
    Dim d, A, k, i, j, m
    Set d = CreateObject("scripting.dictionary")

老师，你理解错我的意思了，我现在重新用函数公式把效果图上传，麻烦老师再帮我修改一下好吗？详情看附件内说明 例子公式效果.rar (119.85 KB, 下载次数: 4)

2015-12-24 09:13 上传

点击文件名下载附件

爱疯

例子修改2.rar (116.96 KB, 下载次数: 9)

2015-12-24 09:22 上传

点击文件名下载附件


            For j = 3 To UBound(A, 2) - 1
                d(A(i, 1))(A(i, 1)) = A(i, 2)    '姓名
                If VBA.IsNumeric(A(i, j)) Then d(A(i, 1))(m) = d(A(i, 1))(m) + A(i, j)   '合计
            Next j


改为


                d(A(i, 1))(A(i, 1)) = A(i, 2)    '姓名
                If VBA.IsNumeric(A(i, UBound(A, 2))) Then d(A(i, 1))(m) = d(A(i, 1))(m) + A(i, UBound(A, 2))  '只累计最后1列

icenotcool

爱疯 发表于 2015-12-24 09:22
For j = 3 To UBound(A, 2) - 1
                d(A(i, 1))(A(i, 1)) = A(i, 2)    '姓 ...

老师，你的修改的不行，可以就着我27楼的附件公式效果修改，好吗？麻烦老师了

爱疯

icenotcool 发表于 2015-12-24 09:42
老师，你的修改的不行，可以就着我27楼的附件公式效果修改，好吗？麻烦老师了

28楼具体是哪儿不行？