多个表格的sumproduct相加如何实现

qmkdtc

需求：想汇总城市公司多个项目的相关信息。现在有项目-甲，项目-乙，未来可能还有项目-丙等，现在想把他们对应信息汇总到城市公司的表格中。
在城市公司中，按对应的条件，求和各项目的值，城市公司BD，等于项目-甲的BD+项目-乙的BD，其他以此类推。
目前想法是在城市公司中，对各项目使用sumproduct选取对应的数值，再相加。但是项目很多，且以后会再增加（项目表格名称前端相同），所以想用VBA实现该操作。
求各位大神帮助，万分感谢！！
项目-甲

	A	B	C
D	1	2	3
E	4	5	6

项目-乙

	A	B	C
D	7	8	9
E	8	7	6

城市公司

	B	C
D	甲的BD+乙的BD	甲的CD+乙的CD
E	甲的BE+乙的BE	甲的CE+乙的CE

opel-wong

请上传附件，模拟数据效果。

qmkdtc

opel-wong 发表于 2019-9-3 14:08
请上传附件，模拟数据效果。

大佬，已上传

opel-wong

qmkdtc 发表于 2019-9-3 15:22
大佬，已上传

你模拟的数据效果呢，黄色区域是计算方式是什么？模拟结果或计算过程。

qmkdtc

opel-wong 发表于 2019-9-3 15:40
你模拟的数据效果呢，黄色区域是计算方式是什么？模拟结果或计算过程。

大佬，我修改了一下，标明了数据小伙和计算方式

opel-wong

qmkdtc 发表于 2019-9-4 16:06
大佬，我修改了一下，标明了数据小伙和计算方式

按你的要求，汇总包含指定关键字的工作表，
只对需操作区域赋值，保留你表中的其它的公式区域。   

用了半小时写代码，希望能帮到你，，

qmkdtc

opel-wong 发表于 2019-9-4 17:25
按你的要求，汇总包含指定关键字的工作表，
只对需操作区域赋值，保留你表中的其它的公式区域。   

万分感谢大佬！

qmkdtc

opel-wong 发表于 2019-9-4 17:25
按你的要求，汇总包含指定关键字的工作表，
只对需操作区域赋值，保留你表中的其它的公式区域。   

大佬 我模仿你的代码  想在其他区域做同样的事，为什么显示 下标越界呀
Sub 字典取数()
    Dim arr, AR(), BR(), CR(), DR(), ER(), FR(), i%, mdic$, sht As Worksheet
    Dim m As Long: m = 0: Dim h As Long: h = 0
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    ReDim AR(1 To 13, 1 To 2) '7\19-1
    ReDim BR(1 To 13, 1 To 2) '7\19-2
    ReDim CR(1 To 13, 1 To 2) '7\19-3
   
    ReDim DR(1 To 5, 1 To 2) '22\26-1
    ReDim ER(1 To 5, 1 To 2) '22\26-2
    ReDim FR(1 To 5, 1 To 2) '22\26-3

   
   
    For Each sht In Sheets
    '7\19-----------------------------------------------------------------------------------------
        If InStr(sht.Name, "项目经营看板--") Then
            arr = sht.UsedRange.Value
            For i = 6 To 18
                mdic = VBA.Trim$(arr(i, 4))
                If d.Exists(mdic) Then
                    h = d(mdic)
                    AR(h, 1) = AR(h, 1) + Val(arr(i, 13)): AR(h, 2) = AR(h, 2) + Val(arr(i, 14))
                    BR(h, 1) = BR(h, 1) + Val(arr(i, 17)): BR(h, 2) = BR(h, 2) + Val(arr(i, 18))
                    CR(h, 1) = CR(h, 1) + Val(arr(i, 21)): CR(h, 2) = CR(h, 2) + Val(arr(i, 22))
                Else
                    m = m + 1
                    d(mdic) = m
                    AR(m, 1) = Val(arr(i, 13)): AR(m, 2) = Val(arr(i, 14))
                    BR(m, 1) = Val(arr(i, 17)): BR(m, 2) = Val(arr(i, 18))
                    CR(m, 1) = Val(arr(i, 21)): CR(m, 2) = Val(arr(i, 22))
                End If

            Next
    '22\26-----------------------------------------------------------------------------------------
            For i = 20 To 24 '计算模块的行序号
                mdic = VBA.Trim$(arr(i, 4))
                If d.Exists(mdic) Then
                    h = d(mdic)
                    DR(h, 1) = DR(h, 1) + Val(arr(i, 13)): DR(h, 2) = DR(h, 2) + Val(arr(i, 14))
                    ER(h, 1) = ER(h, 1) + Val(arr(i, 17)): ER(h, 2) = ER(h, 2) + Val(arr(i, 18))
                    FR(h, 1) = FR(h, 1) + Val(arr(i, 21)): FR(h, 2) = FR(h, 2) + Val(arr(i, 22))
                Else
                    m = m + 1
                    d(mdic) = m
                    DR(m, 1) = Val(arr(i, 13)): DR(m, 2) = Val(arr(i, 14))
                    ER(m, 1) = Val(arr(i, 17)): ER(m, 2) = Val(arr(i, 18))
                    FR(m, 1) = Val(arr(i, 21)): FR(m, 2) = Val(arr(i, 22))
                End If
            Next
        End If
    Next
    With Worksheets("城市经营看板")
        .Activate
        .Range("E7:F19,I7:J19,M7:N19").ClearContents '填写区域清空

    '7\19-----------------------------------------------------------------------------------------
        .Range("I7").Resize(13, 2).Value = AR
        .Range("M7").Resize(13, 2).Value = BR
        .Range("Q7").Resize(13, 2).Value = CR
    '22\26-----------------------------------------------------------------------------------------
        .Range("I22").Resize(5, 2).Value = DR
        .Range("M22").Resize(5, 2).Value = ER
        .Range("Q22").Resize(5, 2).Value = FR
        
    End With
    Set d = Nothing: Erase arr: Erase AR: Erase BR: Erase CR: Erase DR: Erase ER: Erase FR

End Sub

qmkdtc

opel-wong 发表于 2019-9-4 17:25
按你的要求，汇总包含指定关键字的工作表，
只对需操作区域赋值，保留你表中的其它的公式区域。   

大佬，我模仿你的写了一个，但为什么报错，说下标越界，我看了下，貌似是字典添加新数据时会出现问题。

   '7\19-----------------------------------------------------------------------------------------

        If InStr(sht.Name, "项目经营看板--") Then

         arr = sht.UsedRange.Value

            For i = 6 To 18 '计算模块的行序号

                mdic = VBA.Trim$(arr(i, 4))'???

                If d.Exists(mdic) Then

                    h = d(mdic)

                    AR(h, 1) = AR(h, 1) +Val(arr(i, 13)): AR(h, 2) = AR(h, 2) + Val(arr(i, 14)) '计算模块列号

                    BR(h, 1) = BR(h, 1) +Val(arr(i, 17)): BR(h, 2) = BR(h, 2) + Val(arr(i, 18))

                    CR(h, 1) = CR(h, 1) +Val(arr(i, 21)): CR(h, 2) = CR(h, 2) + Val(arr(i, 22))

                Else

                    m = m + 1

                    d(mdic) = m

                    AR(m, 1) = Val(arr(i, 13)):AR(m, 2) = Val(arr(i, 14))

                    BR(m, 1) = Val(arr(i, 17)):BR(m, 2) = Val(arr(i, 18))

                    CR(m, 1) = Val(arr(i, 21)):CR(m, 2) = Val(arr(i, 22))

                End If

            Next

   '22\26-----------------------------------------------------------------------------------------

            For i = 20 To 24 '计算模块的行序号

                mdic = VBA.Trim$(arr(i, 4))'???

                If d.Exists(mdic) Then

                    h = d(mdic)

                    DR(h, 1) = DR(h, 1) +Val(arr(i, 13)): DR(h, 2) = DR(h, 2) + Val(arr(i, 14)) '计算模块列号

                    ER(h, 1) = ER(h, 1) +Val(arr(i, 17)): ER(h, 2) = ER(h, 2) + Val(arr(i, 18))

                    FR(h, 1) = FR(h, 1) +Val(arr(i, 21)): FR(h, 2) = FR(h, 2) + Val(arr(i, 22))

                Else

                    m = m + 1

                    d(mdic) = m

                    DR(m, 1) = Val(arr(i, 13)):DR(m, 2) = Val(arr(i, 14))

                    ER(m, 1) = Val(arr(i, 17)):ER(m, 2) = Val(arr(i, 18))

                    FR(m, 1) = Val(arr(i, 21)):FR(m, 2) = Val(arr(i, 22))

                End If

            Next

        End If