Excel VBA 7.16规则多个Excel表格合并-指定不连续列，通用性再升级

前景提要

另外有小伙伴们表示希望能够提供含有代码的原件，方便自己之后有空的时候研究，所以我也会从本节开始，为大家提供含有代码的原件

场景模拟

数据源还是原来的规则数据源

但是我们今天想要合并的是不连续的表头的数据，比方说，我想要合并姓名和python成绩，针对python的成绩进行专项分析，方便后续的教学活动的安排，那么我们要如何将姓名和python这两列的成绩提取出来呢？

如果我们手工操作的话，我们需要知道姓名和python所在的列数，那么我们用VBA操作呢？也是一样的逻辑，找到列数，将对应的列复制出来，然后综合上节我们学习的数组的使用方法，搞定，来看代码

代码区

Sub test()Dim rng As Range, sth As Worksheet, arr(), book As Workbook, arr1Application.DisplayAlerts = FalseSet book = ActiveWorkbookSet rng = Application.InputBox("请选择要合并的列名", "表头的确定", , , , , , 8)With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then pathn = .SelectedItems(1) End IfEnd Withf = Dir(pathn & "\")Do While f <> "" Workbooks.Open pathn & "\" & f For Each sth In Worksheets arr1 = sth.Rows(1) l = Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next maxl = UBound(arr, 2) k = 0 For Each a In rng k = k + 1 On Error Resume Next num = WorksheetFunction.Match(a, arr1, 0) If Err.Number = 0 Then ReDim Preserve arr(1 To rng.Columns.Count, 1 To maxl + l - 1) For i = 2 To l j = j + 1 arr(k, j) = sth.Cells(i, num) Next i Else ReDim Preserve arr(1 To rng.Columns.Count, 1 To maxl + l - 1) For i = 2 To l j = j + 1 arr(k, j) = "NULL" Next i End If If k <> rng.Columns.Count Then j = maxl End If Next a Next sth 'If ActiveWorkbook.Name <> book.Name Then ActiveWorkbook.Close False 'End Iff = Dir()Loopbook.Worksheets(1).Cells(2, 1).Resize(UBound(arr, 2), rng.Columns.Count) = WorksheetFunction.Transpose(arr)End Sub

相对于上节的代码，本节也是做了部分修改，因为有小伙伴表示经常要合并的工作薄都不是在一个文件夹的，最好能够写成灵活指定文件夹的模式，我也是满足大家的需求，在这里稍微做了一点更改，来看看效果。

首先我们新建一个工作薄，将我们想要合并的表头写在第一行，不不分先后顺序，本案例，我们先写下姓名和python这两个表头

然后选中这两列表头

然后选择我们想要合并的工作薄所在的文件夹区域

接着坐等结果

如果我们的顺序是颠倒过来的呢？

在如果，我们输入的某个字段是不存在的呢？

直接用NULL来表示不存在，通用性显著提升了很多

代码分析

本节的代码主要是在上节的代码的基础之上稍作修改的，所以大致逻辑和结构基本上是相似的

我就来说下本节的更改的几个地方吧

With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then pathn = .SelectedItems(1) End IfEnd With

利用文件夹对话框，根据需要灵活选择，提升代码的通用性

num = WorksheetFunction.Match(a, arr1, 0)

利用数组的方式来判断表头在每个工作表中的位置，就是列数，如果存在的话，就将当前的列所有的数据代入数组中

ReDim Preserve arr(1 To rng.Columns.Count, 1 To maxl + l - 1) For i = 2 To l j = j + 1 arr(k, j) = sth.Cells(i, num) Next i

反之如果不存在的话，就用"NULL"来代表不存在

ReDim Preserve arr(1 To rng.Columns.Count, 1 To maxl + l - 1) For i = 2 To l j = j + 1 arr(k, j) = "NULL" Next i

这里小伙伴们可以根据自己喜好自行更改的，或者是空值都可以的

后面的代码就完全相同了，大家应该在上节已经掌握了。

=============================================