Excel VBA工作薄 7.10 不规则数据的合并-针对指定列数据进行合并

前景提要

通过上一节的学习，我们成功实现了将多个工作表的规则或者不规则数据合并到一个工作表的操作，这两个功能的能够在一定程度上满足大家的日常工作需要，提升我们的工作效率，避免出现重复简单的机械操作的情况，这也是VBA的优势所在。

在分享规则数据合并的时候，就有小伙伴告诉我说，想要分享一下，如果只针对某几列来进行操作的话，要如何用vba来实现呢？原来日常处理的报表中有一些数据并不是我们需要的，我们在进行汇总数据交给上司汇报工作的时候，一般都是针对几列关键性数据进行分析的，所以今天我们就来学习下，如果单独针对指定的几列，如果来操作呢？

场景模拟

这里我们还是继续用上节的数据，继续玩

在实际数据分析的时候，我们一般只需要分析各学科的成绩就好了，并不需要分析总分这一列的数据，所以我们只需要针对其他的学科列进行汇总分析

而总分这一列的数据就不要汇总了。这样的场景确实是在工作中比较常见的，只针对其中的某几列来进行数据的合并

代码区

Sub testadd()Dim sth As Worksheet, new_sth As Worksheet, arr, rng As Range, arrsth, arrTSet rng = Application.InputBox("请选择要合并的标头", "标头的确定", , , , , , 8)arr = rngWorksheets.Add after:=Worksheets(Worksheets.Count)ActiveSheet.Name = "汇总表"Set new_sth = ActiveSheetk = 0For Each sth In Worksheets If sth.Name <> "汇总表" Then k = k + 1 If k = 1 Then arrsth = sth.UsedRange.Rows(1) l2 = sth.Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To UBound(arr, 2) On Error Resume Next num = WorksheetFunction.Match(arr(1, i), arrsth, 0) If Err.Number = 0 Then l = new_sth.Cells(1, Columns.Count).End(xlToLeft).Column If l = 1 And new_sth.Cells(1, 1) = "" Then sth.UsedRange.Columns(num).Copy new_sth.Cells(1, 1) Else sth.UsedRange.Columns(num).Copy new_sth.Cells(1, l + 1) End If End If Next i Else arrsth = sth.UsedRange.Rows(1) l3 = new_sth.Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To UBound(arr, 2) On Error Resume Next num = WorksheetFunction.Match(arr(1, i), arrsth, 0) If Err.Number = 0 Then arrT = new_sth.Range(Cells(1, 1), Cells(1, l3)) On Error Resume Next num2 = WorksheetFunction.Match(arr(1, i), arrT, 0) If Err.Number <> 0 Then new_sth.Cells(1, num) = arr(1, i) sth.UsedRange.Columns(num).Offset(1, 0).Copy new_sth.Cells(l3 + 1, num) Else sth.UsedRange.Columns(num).Offset(1, 0).Copy new_sth.Cells(l3 + 1, num2) End If End If Next i End If End IfNext sthEnd Sub

我们来看看实际执行的效果

假设我们只需要合并姓名，vba,python 这三列的成绩，同样的是，在B班，C班这两个表也是这样的规则，

来看看最终执行的效果

A班主修VBA和python ，所有他们的数据都汇总过来了

而B班主修C++和java的，所以VBA和python的成绩是不存在的，所以都是空，

C班主修python和java的，他有python的成绩，然后就仅仅是汇总了python的成绩

就达到了我们理想的效果

当然数据看起来是比较的乱，毕竟因为我们的数据都是虚构的，多少有点不合实际，大家主要掌握方法为主。

代码分析

从第一个for循环之前的步骤，小编就不在说明了，这些都太简单了。

来说下第一个表的判断，有了第一个判断，后面的就很简单了

arrsth = sth.UsedRange.Rows(1) l2 = sth.Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To UBound(arr, 2) On Error Resume Next num = WorksheetFunction.Match(arr(1, i), arrsth, 0) If Err.Number = 0 Then l = new_sth.Cells(1, Columns.Count).End(xlToLeft).Column If l = 1 And new_sth.Cells(1, 1) = "" Then sth.UsedRange.Columns(num).Copy new_sth.Cells(1, 1) Else sth.UsedRange.Columns(num).Copy new_sth.Cells(1, l + 1) End If End If Next i

首先我们先获得当前要汇总的表的标头，赋值给数组arrsth

arrsth = sth.UsedRange.Rows(1)

然后开始我们的for循环，通过match方法来判断，我们选择的标头，即姓名，vba，python是否在当前要汇总的工作表的表头中

如果存在，并且这是我们复制的第一个表的第一列，则将数据复制在汇总表的第一列

sth.UsedRange.Columns(num).Copy new_sth.Cells(1, 1)

否则就是汇总在汇总表的第l+1列

sth.UsedRange.Columns(num).Copy new_sth.Cells(1, l + 1)

判断的依据就是k=1,同时汇总表的cells(1,1)这个单元格内容为空

看看断点执行效果分析

第一次我们需要复制的是姓名这一列，如果第一次复制的话，我们需要复制在A1单元格，

得到这样的效果

为什么这里要这样判断呢？因为我们得到的L，在都是空格的情况下和只有一列数据的情况下，他返回的都是1，所以这里一定要做下判断，方法就是A1单元格是否为空

而到了后面第二个甚至以后的单元格，我们就不需要做这样纤细的判断了，因为标头已经存在了，我们只需要找到标头的位置，对号入座，就可以了。

arrsth = sth.UsedRange.Rows(1) l3 = new_sth.Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To UBound(arr, 2) On Error Resume Next num = WorksheetFunction.Match(arr(1, i), arrsth, 0) If Err.Number = 0 Then sth.UsedRange.Columns(num).Offset(1, 0).Copy new_sth.Cells(l3 + 1, num) End If Next i

所以第二段代码就简单了很多

不需要做出判断，找到对应的num之后，就可以直接复制到对应的num行了。