Excel VBA 7.23 报表横向合并，横列数据都不全！怎么办？

一起学习，一起进步~~

昨天分享了关于多个报表横向合并数据的操作，相对于之前我们常见的纵向合并数据，横向合并数据在一些场合中也是经常使用到的，今天我们将针对这个问题进行更进一步的研究，因为昨天我们分享的方法适用于仅仅是合并，没有太多的要求，但是按照惯例，日常工作中肯定会碰到很多不标准的数据，比方说参照列数据不全，字段数据也不全的情况，那么这些情况要如何处理呢？

场景模拟

还是使用我们上一节使用的案列来说明，为了适应场景，我们改造下数据源，第一个表去掉A1，第二个表去掉A,A7第三个表去掉A2,A10,

总之三个表没有一个表的字段是完整的，尽可能的接近我们日常使用的数据情况

那么如何讲这样的一份数据汇总在一个工作表中呢？

代码区

上节我们主要是用了数组的方式，那么今天我们来换种方法，准确的说是新增一种组合方法，字典+数组

Sub twotwo()Dim nsth As Worksheet, arr(), arr1(), zd As ObjectSet zd = CreateObject("scripting.dictionary")h = 0For Each sth In Worksheets For x = 1 To sth.Cells(Rows.Count, 1).End(xlUp).Row k1 = sth.Cells(x, 1) If Not zd.exists(k1) Then zd.Add k1, k1 End If Next xNext sthcountN = zd.CountFor Each sth In Worksheets 'If sth.Name <> nsth.Name Then k = k + 1 If k = 1 Then l = sth.Cells(1, Columns.Count).End(xlToLeft).Column counts = Worksheets.Count ReDim Preserve arr(1 To countN, 1 To l) For i1 = 1 To sth.Cells(Rows.Count, 1).End(xlUp).Row For j1 = 1 To l arr(i1, j1) = sth.Cells(i1, j1) Next j1 Next i1 Else arrt = sth.UsedRange.Columns(1) l = sth.Cells(1, Columns.Count).End(xlToLeft).Column new_arr = WorksheetFunction.Transpose(arrt) ReDim Preserve arr(1 To countN, 1 To UBound(arr, 2) + l - 1) 'rrrt = WorksheetFunction.Transpose(WorksheetFunction.Index(arr, 0, 1)) For i = 1 To UBound(new_arr) On Error Resume Next num = WorksheetFunction.Match(new_arr(i), WorksheetFunction.Transpose(WorksheetFunction.Index(arr, 0, 1)), 0) If Err.Number = 0 Then For j = 2 To l arr(num, UBound(arr, 2) + j - l) = sth.Cells(i, j) Next j Else h = i1 arr(h, 1) = new_arr(i) For j = 2 To l arr(h, UBound(arr, 2) + j - l) = sth.Cells(i, j) Next j End If Next i End If 'End IfNext sthWorksheets.Add after:=Worksheets(Worksheets.Count)Set nsth = ActiveSheetnsth.Name = "横向汇总（2）"nsth.Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arrEnd Sub

来看看最终的效果

原始参照列中有的字段，应该为空的都为空，本身有数据的，也增加了相应的数据，其中在第一个表中被我们删除的数据A1，单独增加到行，数据也没有缺少，

再次得到了我们的要求

代码分析

本次代码，我们多引入了一个概念，就是字典，字典在VBA中主要的作用，就是用统计非重复数据的，在字典中，所有的数据都具有唯一性

在本案例中

For Each sth In Worksheets For x = 1 To sth.Cells(Rows.Count, 1).End(xlUp).Row k1 = sth.Cells(x, 1) If Not zd.exists(k1) Then zd.Add k1, k1 End If Next xNext sth

就是通过一个小小的循环，在实现字典的构造

1. 首先我们先声明一个字典，这是标准结构，大家直接套用即可

Set zd = CreateObject("scripting.dictionary")

1. 通过循环来构造字典

1. 判断字典中，这个值是否存在

1. 存在，就跳过

2. 不存在，则写入字典

If Not zd.exists(k1) Then'判断是否存在 zd.Add k1, k1'不存在写入 End If

为什么要构造一个字典呢？因为我们知道动态数组，每次重置只能更改他的二维的坐标，一维坐标是无法更改的，放在excel中就是只能增加列，不能增加行

所有我们需要先得到总共有多少行，那么得到了字典之后，如何得到总个数呢？

countN = zd.Count

好了，现在有了总行数，我们就可以声明一个动态数组了，利用动态数组不断的根据行

当进行第一次循环的时候，我们通过遍历循环的方式得到一个数组，这个数组就是第一个表的全部数据

If k = 1 Then l = sth.Cells(1, Columns.Count).End(xlToLeft).Column counts = Worksheets.Count ReDim Preserve arr(1 To countN, 1 To l) For i1 = 1 To sth.Cells(Rows.Count, 1).End(xlUp).Row For j1 = 1 To l arr(i1, j1) = sth.Cells(i1, j1) Next j1 Next i1

当从第二个工作表的时候，我们就要进行判断了，这里我们来看看是如何进行判断的

我们先将当前工作表的第一列复制给输入arrt,然后我们去判断，当前arrt中的数据是否在我们之前已经汇总好数组中，判断的方式就用我们之前学习过的match方法

我们这里先对数组进行下增加列的操作

ReDim Preserve arr(1 To countN, 1 To UBound(arr, 2) + l - 1)

增加多少列呢？当前数组的列数+当前活动工作表的列数-第一行参考列，这样大家应该很好理解了。

For i = 1 To UBound(new_arr) On Error Resume Next num = WorksheetFunction.Match(new_arr(i), WorksheetFunction.Transpose(WorksheetFunction.Index(arr, 0, 1)), 0) If Err.Number = 0 Then For j = 2 To l arr(num, UBound(arr, 2) + j - l) = sth.Cells(i, j) Next j Else h = i1 arr(h, 1) = new_arr(i) For j = 2 To l arr(h, UBound(arr, 2) + j - l) = sth.Cells(i, j) Next j End If Next i

这就是今天判断了，如果存在就是直接在原来数组的后面写入数据，如果不存在的话，就在原有数组的后面写入，这里要注意，并不是新增数组的行数，而是原有数组的非空行，怎么理解呢？

在第一次循环第一个表的时候，i1正好代表了，所有的行数，所以这里我们直接将H=i1的行数，就可以得到最后一个非空数组的位置了，

这里11的这个位置还是空值

将数组的状态和最终形成的状态对比着看，这样大家会更好理解一点

后面的思路就和上节相同了。

好了~明晚20：00，准时再见。