Excel VBA工作薄 5.9多个工作薄求和，不仅仅是合并

前景提要

忽然发现大家的日常工作中会使用到的场景真的好多，不过这样也好，大家告诉我相关的场景，小编也是尽量的去实现，即帮助了大家，也锻炼了自己的能力，一举两得，哈哈

有童鞋说，他想要的效果并不仅仅是数据合并，简单的将各种数据合并在一起对他来说并没有太大的作用，它希望能够再进行数据合并的同时，顺带进行数据的计算，比方说数据的求和，这样就不用在数据完成合并之后再进行求和汇总了，其实这也并不难，我们开工吧

场景模拟

正好昨晚趁着放假有空，重温了下复仇者联盟系列，今天我们就用复仇者联盟的数据来坐下例子吧，假设我们通过各种渠道成功的统计出了漫威的几个英雄人物在每一集的杀敌数，我们需要将四季的所有的英雄的杀敌汇总并求和，得到一个最终的数据，能够展示每个英雄的杀敌数的，我们依然还是利用之前已经写好的合并数据的代码的基础上，继续写

这是我们假设的漫威英雄的杀敌战果

image.png

总共有4个文件需要我们汇总

image.png

方法分析

之前我们汇总数据的时候，仅仅是将需要的数据复制粘贴过来就可以了，并没有做其他的操作，而现在进行求和的话，方法上面会稍微有一点不同，因为我们之前不涉及数据的任何操作，仅仅是汇总，而现在我们不仅是汇总，还需要进行求和，人工操作的话，我们需要遍历每个表，找到对应的人的数据，比方说我们要汇总钢铁侠的数据，这个时候我们就要翻遍4个工作薄，然后讲钢铁侠所在的哪一行的数据进行相加，然后以此类推，如果碰到某个表没有钢铁侠的话，还不能够计算，只能跳过打开下一个，那么这样的一个过程，遍历文件夹我们已经学过了，批量打开工作薄我们也学习了，现在就是数据的相加的问题了，如果单纯的用数组的话，我们还需要遍历数组，今天我们换种方法，我们用字典+数组的方法来实现，字典可能很多小伙伴们都比较陌生，没事，先理解逻辑，直接套用即可。

代码区

Sub test()

Dim zd As Object, pathn, arr()

pathn = ThisWorkbook.Path

Set zd = CreateObject("scripting.dictionary")

f = Dir(pathn & "\")

k = 0

Do While f <> ""

If f <> "test.xlsm" Then

    Workbooks.Open pathn & "\" & f

    l = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To l

        If zd.Exists(Cells(i, 1).Value) Then

            n = zd(Cells(i, 1).Value)

            arr(2, n) = arr(2, n) + Cells(i, 2)

            arr(3, n) = arr(3, n) + Cells(i, 3)

            Else

                k = k + 1

                zd(Cells(i, 1).Value) = k

                ReDim Preserve arr(1 To 3, 1 To k)

                arr(1, k) = Cells(i, 1)

                arr(2, k) = Cells(i, 2)

                arr(3, k) = Cells(i, 3)

        End If

    Next i

    ActiveWorkbook.Close True

End If

f = Dir()

Loop

ActiveSheet.Cells(2, 1).Resize(k, 3) = WorksheetFunction.Transpose(arr)

End Sub

我们来看看最终的效果

image.png

完美的实现了数据的合计，并且展示了相关的数据

代码分析

今天的新知识点就是字典，字典的话，我们现在暂时不去涉及，因为并不是简单的几句话就可以说完的，后面我们会专门重点开一个系列来说下字典的，今天我们先接触下字典的使用方法就好，字典的特点就是相同的值在字典中只能出现一个，并且也只能对应一个值。

案例中，比方说黑寡妇的数据，在第一个表出现了，在第一个表的时候，黑寡妇的数据是第一次显示，所以字典中并不存在黑寡妇的数据，我们在字典中将黑寡妇的值对应为它在第一表中的行号

image.png

它的两个值，则通过定义动态数组的方式进行赋值

 ReDim Preserve arr(1 To 3, 1 To k)

 arr(1, k) = Cells(i, 1)

 arr(2, k) = Cells(i, 2)

 arr(3, k) = Cells(i, 3)

这个动态数组的代码的逻辑，大家应该能够理解了，因为我们前后已经使用了很多次了。

然后到我们打开第二个表的时候，看看黑寡妇的数据有什么变化，因为是第二个数据表了，那么黑寡妇的数据肯定是已经在字典中存在了，所以这个时候就直接进行数据的更改就好了，而不用再次增加数据

image.png

完整代码

Sub test()

Dim zd As Object, pathn, arr()

pathn = ThisWorkbook.Path

Set zd = CreateObject("scripting.dictionary")

f = Dir(pathn & "\")

k = 0

Do While f <> ""

If f <> "test.xlsm" Then

    Workbooks.Open pathn & "\" & f

    l = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To l

        If zd.Exists(Cells(i, 1).Value) Then '判断数据在字典中是否存在

            n = zd(Cells(i, 1).Value) '如果存在就讲原来的数据和新的数据相加

            arr(2, n) = arr(2, n) + Cells(i, 2)

            arr(3, n) = arr(3, n) + Cells(i, 3)

            Else '如果不存在则进行赋值，并更改动态数组

                k = k + 1

                zd(Cells(i, 1).Value) = k

                ReDim Preserve arr(1 To 3, 1 To k)

                arr(1, k) = Cells(i, 1)

                arr(2, k) = Cells(i, 2)

                arr(3, k) = Cells(i, 3)

        End If

    Next i

    ActiveWorkbook.Close True

End If

f = Dir()

Loop

ActiveSheet.Cells(2, 1).Resize(k, 3) = WorksheetFunction.Transpose(arr) '将最终的结果在汇总的数据表内输出

End Sub