VBA批量合并表格

需求分析

其实这个需求手动操作很好实现，复制所有表格粘贴到同一个表格中。

用代码也是可以模拟这个操作来实现的。

所以实现的步骤基本就是:

1. 获取同一个文件夹下的所有文件

2. 获取文件中的表格及其内容

3. 复制表格中有数据的内容

4. 粘贴内容到合适的位置

获取文件

首先，我百度搜索了【VBA获取文件夹下所有文件】，找到了个Dir函数，再去Excel的帮助文档中查Dir函数

Dir 函数

返回一个String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。

语法

Dir[(pathname[, attributes])]

Dir函数的语法具有以下几个部分：

部分 描述
pathname 可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 ("")。
attributes 可选参数。常数或数值表达式，其总和用来指定文件属性。如果省略，则会返回匹配 pathname 但不包含属性的文件。

设置值

attributes 参数的设置可为：

常数 值 描述
vbNormal 0 (缺省) 指定没有属性的文件。
vbReadOnly 1 指定无属性的只读文件
vbHidden 2 指定无属性的隐藏文件
VbSystem 4 指定无属性的系统文件 在Macintosh中不可用。
vbVolume 8 指定卷标文件；如果指定了其它属性，则忽略vbVolume 在Macintosh中不可用。
vbDirectory 16 指定无属性文件及其路径和文件夹。
vbAlias 64 指定的文件名是别名，只在Macintosh上可用。

这样看我还是没太懂怎么用，但是帮助文档中还贴心的给了示例

Dim MyFile, MyPath, MyName

' 返回“WIN.INI”(在 Microsoft Windows 中) （如果该文件存在）。
MyFile = Dir("C:\WINDOWS\WIN.ini")

' 返回带指定扩展名的文件名。如果超过一个 *.ini 文件存在，
' 函数将返回按条件第一个找到的文件名。
MyFile = Dir("C:\WINDOWS\*.ini")

' 若第二次调用 Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个 *.ini 文件。
MyFile = Dir

' 返回找到的第一个隐式 *.TXT 文件。
MyFile = Dir("*.TXT", vbHidden)

' 显示 C:\ 目录下的名称。
MyPath = "c:\"    ' 指定路径。
MyName = Dir(MyPath, vbDirectory)    ' 找寻第一项。
Do While MyName <> ""    ' 开始循环。
    ' 跳过当前的目录及上层目录。
    If MyName <> "." And MyName <> ".." Then
        ' 使用位比较来确定 MyName 代表一目录。
        If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            Debug.Print MyName    ' 如果它是一个目录，将其名称显示出来。
        End If
    End If
    MyName = Dir    ' 查找下一个目录。
Loop

对于从事编程的我来说，这段示例挺清晰明了了，Dir("C:\WINDOWS\WIN.ini")中使用了绝对路径，这样并不是很灵活，所以我又百度了【VBA获取当前文件路径】，找到了ThisWorkbook对象的Path属性，出于习惯，我编了一小段代码验证了一下

Public Sub mysub()

    MsgBox ThisWorkbook.Path

End Sub

运行代码后输出了我的Excel文件所在的文件夹的路径。然后再试试

Public Sub mysub()

    MsgBox Dir(ThisWorkbook.Path)

End Sub

居然是个空字符串，经过一番思考尝试，发现加个/就可以输出文件夹下的第一个文件的文件名了。

比如我的Excel文件路径为【D:/A/B.xls】，那么ThisWorkbook.Path的值就是【D:/A】，如果后面不加/，就会认为是查找D盘下面叫A的文件，查询后没有这个文件，就返回空字符串""了。

接下来试图输出所有的文件名，就要用到循环了，在示例里后面就是个循环结构，根据它可以看出VBA循环语句的写法

Do While 循环条件

Loop

示例里还有一个要划重点的地方

' 若第二次调用 Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个 *.ini 文件。
MyFile = Dir

验证一下

Public Sub mysub()

    Dim fileName As String

    fileName = Dir(ThisWorkbook.Path & "/")
    
    MsgBox fileName
    
    fileName = Dir
    
    MsgBox fileName

End Sub

所以输出文件夹下所有文件文件名的代码就是

Public Sub mysub()

    Dim fileName As String

    fileName = Dir(ThisWorkbook.Path & "/")
    
    Do While fileName <> ""
        MsgBox fileName   
        fileName = Dir
    Loop

End Sub

运行结果和期待的一样。

获取数据

知道了怎么获取文件名，然后就是通过文件名获取数据了。

第一步还是百度，知道了有个函数叫GetObject，然后查帮助文档

GetObject 函数

返回文件中的 ActiveX 对象的引用。

语法

GetObject([pathname] [, class])

帮助文档的搜索对大小写敏感，搜索getObject是查不出GetObject的。

可以看到函数返回的是个对象，于是得弄清楚返回的是什么对象把，又查到了个TypeName函数

TypeName 函数

返回一个 String，提供有关变量的信息。

语法

TypeName(varname)

必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。

测试一下

Public Sub mysub()

    Dim filePath As String
    Dim fileName As String
    
    filePath = ThisWorkbook.Path & "\"
    
    fileName = Dir(filePath & "*.xls")
    
    Set wb = GetObject(filePath & fileName)
    
    MsgBox TypeName(wb)
    
End Sub

输出结果是Workbook，所以打开Excel文档，返回的是Workbook对象，通过这个对象就可以操作数据了。

通过Range对象可以获取一个区域的数据，它需要提供区域的起始和结束单元格做为参数，

通过Range对象的Cells属性，可以获得单元格，测试

Public Sub mysub()

    Dim filePath As String
    Dim fileName As String
    Dim wb As workbook
    
    filePath = ThisWorkbook.Path & "\"
    
    fileName = Dir(filePath & "*.xls")
    
    Set wb = GetObject(filePath & fileName)
    
    MsgBox wb.Sheets(1).Cells(1, 1).Value
    
End Sub

输出了第1行第1列单元格的数据，可以看到单元格索引是从1开始的，而不是一般编程的0。

那么表格那么大，有数据的范围怎么获取呢？

Range对象的End方法，效果相当于按住【End】键同时按方向键，所以它的参数有四种选择：

1. xlUp往上
2. xlDown往下
3. xlToLeft往左
4. xlToRight往右

获取表格中有数据的行数可以使用Cell(1,1).End(xlDown).Row，效果是从第1行第1列开始往下数，到第一个没有数据的单元格结束，这样就有个问题，如果中间某一行有空值，行数统计就不对了，还有一个问题，如果只有第1行第1列有数据，则这条语句会返回表格的最大行数，具体原因可以通过按【End】+方向键体会。

然后还有一种方法，Cell(65536,1).End(xlUp).Row，效果是从第65536行的第1列往上数，到第一个有数据的单元格结束，这样比较通用。

经过多次实验，可以猜测End方法就是往四个方向数，遇到与起始单元格情况不同的单元格就结束。

这里又有个问题，怎么知道数据表支持的最大行和最大列，这个Excel版本不同就不同的，2003版是65536行，2007版及之后是1048576行，这个问题还没解决。

总之现在是能获得数据区域了，左上角单元格为Cells(1,1)，右下角单元格为Cells(Cell(65536,列数).End(xlUp).Row，列数)，其实列数也能代码判断出来，但是合并是要相同结构的，列数一般是已知且固定不变的，就不用浪费CPU去判断了。

现在总算能获得有数据的区域了

Public Sub mysub()
    
    '列数
    Dim colNumber As Integer
    colNumber = 2
    
    '左上角
    Dim startCell As Range
    Set startCell = ThisWorkbook.Sheets(1).Cells(1, 1)
    
    '右下角
    Dim endCell As Range
    Set endCell = ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Cells(65536, colNumber).End(xlUp).Row, colNumber)
    
    '将有数据的区域选择出来
    ThisWorkbook.Sheets(1).Range(startCell, endCell).Select
    
End Sub

运行之后准确的选择了有数据的区域。

复制数据

复制比较简单，看到Excel帮助文档的Range.Copy方法

Range.Copy 方法
将单元格区域复制到指定的区域或剪贴板中。
语法

表达式.Copy(Destination)

表达式 一个代表 Range 对象的变量。

编一小段代码测试一下

Public Sub mysub()

    Dim range1 As range
    Dim range2 As range
    
    Set range1 = ThisWorkbook.Sheets(1).range("A1")
    Set range2 = ThisWorkbook.Sheets(1).range("B1")
    
    range1.Copy range2

End Sub

运行这段代码成功的把A1单元格的值复制到了B1单元格中。

编程习惯方法调用的时候参数放括号里了，所以一开始写成了range1.Copy(range2)，运行时居然报错了，查了一下虽然没弄明白，但是似乎是括号会把对象转换成它的值，相当于range1.Copy range2.Value。

粘贴数据

Range.Copy就已经能把数据复制和粘贴了，现在需要弄清粘贴到哪里，就是粘贴到哪个Range。

需要的是粘贴到目标数据表的数据的最后一行的下一行，数据的最后一行可以用Cells(65536,1).End(xlTop).Row获取。

完成需求

把上面学到的东西拼起来，就可以实现多个文件的合并了。

首先获取文件，假设需要合并的文件放在了data文件夹里面，data文件夹里有3个Excel文件：

1. A.xls

index	name
1	A

2. B.xls

index	name
1	B

3. C.xls

index	name
1	C

下面要做的是把这三个文件合并在一起，在与data目录同级的文件夹下建一个空的合并.xlsm，打开宏代码编辑页面，先获取data目录下的所有Excel文件

Public Sub mysub()
    
    '声明文件夹路径
    Dim filePath As String
    
    '声明文件名称
    Dim fileName As String
    
    '文件夹路径为当前Excel目录下的data目录
    filePath = ThisWorkbook.Path & "/data/"
    
    '第一个Excel的文件名用Dir方法获取，获取所有.xlsx结尾的文件
    fileName = Dir(filePath & "*.xlsx")
    
    '先显示一下每个文件的名称，确保上面的代码能正确工作
    Do While fileName <> ""
    
        MsgBox filePath & fileName
        
        '获取下一个文件的文件名
        fileName = Dir
        
    Loop
    
End Sub

运行后显示是正确的，下一步是获取数据

Public Sub mysub()
    
    '声明文件夹路径
    Dim filePath As String
    
    '声明文件名称
    Dim fileName As String
    
    '声明文件对应的工作簿
    Dim fileWorkbook As Workbook
    
    '文件夹路径为当前Excel目录下的data目录
    filePath = ThisWorkbook.Path & "/data/"
    
    '第一个Excel的文件名用Dir方法获取，获取所有.xlsx结尾的文件
    fileName = Dir(filePath & "*.xlsx")
    
    '先显示一下每个文件的名称，确保上面的代码能正确工作
    Do While fileName <> ""
    
        '当前文件的工作簿
        Set fileWorkbook = GetObject(filePath & fileName)
        
        '输出第一格单元格的值看看
        MsgBox fileWorkbook.Sheets(1).range("A1").Value
        
        '获取下一个文件的文件名
        fileName = Dir
        
    Loop
    
End Sub

成功输出了每个文件第一个单元格的值。然后就是获取我们要复制的区域了和粘贴区域，再把数据复制粘贴就可以了。

Public Sub mysub()

    '标题占据的行数
    Dim titleLineCount As Integer
    
    '表格的列数
    Dim colCount As Integer
    
    '目标表格已有数据的行数
    Dim dataLineCount As Integer
    
    titleLineCount = 1
    
    colCount = 2
    
    dataLineCount = titleLineCount
    
    '声明文件夹路径
    Dim filePath As String
    
    '声明文件名称
    Dim fileName As String
    
    '声明文件对应的工作簿
    Dim fileWorkbook As Workbook
    
    '文件夹路径为当前Excel目录下的data目录
    filePath = ThisWorkbook.Path & "/data/"
    
    '第一个Excel的文件名用Dir方法获取，获取所有.xlsx结尾的文件
    fileName = Dir(filePath & "*.xlsx")
    
    '先显示一下每个文件的名称，确保上面的代码能正确工作
    Do While fileName <> ""
    
        '要复制的区域
        Dim copyRange As range
        
        '要粘贴的区域
        Dim paste As range
        
        '左上角单元格
        Dim startCell As range
        
        '右下角
        Dim endCell As range
        
        '当前文件的工作簿
        Set fileWorkbook = GetObject(filePath & fileName)
        
        Set startCell = fileWorkbook.Sheets(1).Cells(titleLineCount + 1, 1)
        
        Set endCell = fileWorkbook.Sheets(1).Cells(fileWorkbook.Sheets(1).Cells(65536, colCount).End(xlUp).Row, colCount)
        
        Set copyRange = fileWorkbook.Sheets(1).range(startCell, endCell)
        
        Set pasteRange = ThisWorkbook.Sheets(1).range(ThisWorkbook.Sheets(1).Cells(dataLineCount + 1, 1), ThisWorkbook.Sheets(1).Cells(dataLineCount + copyRange.Rows.Count, colCount))
        
        '目标文件的数据行数更新一下
        dataLineCount = dataLineCount + copyRange.Rows.Count
        
        '复制并粘贴
        copyRange.Copy pasteRange
        
        '关闭当前表格文件
        fileWorkbook.Close (False)
        
        '获取下一个文件的文件名
        fileName = Dir
        
    Loop
    
End Sub

来看看效果

总结

我学习编程，就喜欢动手实现，确实通过这个小需求，也学到了不少东西：

1. Dir函数用于循环获取文件名
2. GetObject函数用来获取文件数据
3. End函数用来获取表中有数据的行数和列数
4. VBA的循环语句的写法
5. 更熟悉和习惯了VBA的编程风格