多表金额汇总续——字典法

《美妞》

要求

1、合计当中每个费用科目金额等于后面4个部门对应的费用科目金额合计

2、存在困难是每个部门的费用科目是不是固定的

比如人力部交通费用是在第5行，但是拓展部的交通费用科目是在第2行

3、有没有便捷的方式直接取到各个表当中对应费用科目的金额合计

思路

字典定位累加

代码如下：

Sub mySum3()

Dim myDic As Object

Dim sumArr(1 To 300, 1 To 15), Brr()

Dim bRow As Integer, bCol As Integer, aRow As Integer

Dim Sht As Worksheet, yCol As Integer

    Set myDic = CreateObject('Scripting.dictionary')

    For Each Sht In Worksheets

        If Sht.Name <> '合计' Then

            Brr = Sht.UsedRange.Value

            For bCol = 2 To UBound(Brr, 2) - 1    '首先处理月标题

                yCol = Val(Brr(1, bCol)) + 1

                If yCol < 2="" or="" ycol=""> 13 Then   '如果标题不是1-12月则将数据汇总列设置到最后一列

                    Brr(1, bCol) = 15

                Else

                    Brr(1, bCol) = yCol

                End If

            Next

            For bRow = 2 To UBound(Brr, 1)  '开始汇总数据

                If myDic.exists(Brr(bRow, 1)) = False Then

                    aRow = myDic.Count + 1

                    myDic.Add Brr(bRow, 1), aRow

                    sumArr(aRow, 1) = Brr(bRow, 1)

                End If

                aRow = myDic.Item(Brr(bRow, 1))

                For bCol = 2 To UBound(Brr, 2) - 1

                    yCol = Brr(1, bCol)

                    sumArr(aRow, yCol) = Brr(bRow, bCol) + sumArr(aRow, yCol)

                    sumArr(aRow, 14) = sumArr(aRow, 14) + Brr(bRow, bCol)

                Next

            Next

        End If

    Next

    Range('A2').Resize(UBound(sumArr)).EntireRow.ClearContents

    Range('a2').Resize(myDic.Count, UBound(sumArr, 2)).Value = sumArr

End Sub

***华丽分割线***

合伙人

祝福大家

阖家欢乐

红包多多