朋友兼老乡的工作需要处理很多表格，今天就有个需求是把一个文件夹下的相同结构的表放在一张表中。开始想这不挺简单嘛，复制粘贴就行，但是表多了就痛苦了。于是乎刚好使用VBA来帮忙。
image
需求分析
其实这个需求手动操作很好实现，复制所有表格粘贴到同一个表格中。
用代码也是可以模拟这个操作来实现的。
所以实现的步骤基本就是:
-
获取同一个文件夹下的所有文件
-
获取文件中的表格及其内容
-
复制表格中有数据的内容
-
粘贴内容到合适的位置
获取文件
首先，我百度搜索了【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])
<font color="red">帮助文档的搜索对大小写敏感，搜索getObject是查不出GetObject的。</font>
可以看到函数返回的是个对象，于是得弄清楚返回的是什么对象把，又查到了个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列单元格的数据，可以看到单元格索引是从<font color="red">1</font>开始的，而不是一般编程的<font color="red">0</font>。
那么表格那么大，有数据的范围怎么获取呢？
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的编程风格
网友评论