VBA批量合并表格

需求分析

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

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

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

获取同一个文件夹下的所有文件
获取文件中的表格及其内容
复制表格中有数据的内容
粘贴内容到合适的位置

获取文件

首先，我百度搜索了【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】键同时按方向键，所以它的参数有四种选择：

xlUp往上
xlDown往下
xlToLeft往左
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文件：

A.xls

index	name
1	A

B.xls

index	name
1	B

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

来看看效果

总结

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

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

posted on 2020-04-22 19:20 iknow的笔记本阅读(1344) 评论(0) 编辑收藏举报

刷新页面返回顶部

iknow的笔记本