VBA编程知识点（10）——Dir函数
学习自杨洋老师《全民一起VBA》
1. 在VBA中，dir函数可以返回一个文件夹下一个文件的名字（包含后缀）。
示例代码：
filename = Dir("F:userdataDesktop新建文件夹")
dir后面的参数应该以反斜杠“”结尾，这样才能返回该文件夹下的文件名称。否则“新建文件夹”会被当成一个文件名进行处理。
Dir运行一次只能得到一个文件名。为得到下一个文件名，代码应该这样写：filename = Dir。
Dir后面不写任何参数，如果写了与前面相同的参数"F:userdataDesktop新建文件夹"，则会重新扫描该文件夹，又得到第一个文件名，如果更改为其他文件夹，就扫描该文件夹，得到它的第一个文件名
如果文件夹中有n个文件，或者说有n个符合条件的文件，那么当Dir运行第n+1次时，则返回一个空字符串，代表已经查找完所有的文件。Dir运行第n+2次时，程序将报错。
2. 扫描一个文件夹下所有文件的通用模板
Dim filename as string
filename = Dir("F:userdataDesktop新建文件夹")  '可以更改为任意文件夹
Do while filename <> ""
	相关操作
	filename = Dir  '获取下一个文件名
Loop
3. Dir扫描符合条件的文件名（通配符*）
示例代码：
F = Dir("F:userdataDesktop新建文件夹*.xls")，扫描所有后缀为.xls的文件。
4. 判断一个文件是否存在
示例代码：
F = Dir("F:userdataDesktop新建文件夹123.xls")
如果文件123.xls存在，则返回字符串123.xls，如果不存在，则返回空字符串。
5. 扫描文件和子文件夹名称
一般情况下，Dir函数只返回文件名，而不返回子文件夹名。如果想要两者都返回，则需要加上vbDirectory参数。示例代码如下：
F = Dir("F:userdataDesktop新建文件夹" , vbDirectory)
特别要注意的是，子文件夹包括“.”和“..”两个特殊名字，分别代表本目录F:userdataDesktop新建文件夹及其父目录F:userdataDesktop。
Dir函数只能返回第一层的子文件夹和文件名，子文件夹下的文件与文件夹不返回。

	

写在前面：
Office办公套件(Word，Excel，PowerPoint等)是我们最常接触的工作软件。它们的功能非常强大：Word可以制作排版精美的文档，Excel有强大的数据统计与处理功能，PowerPoint则可以很好地方便我们向他人展示我们的观点。只要用好这三个软件，处理日常的工作和生活事务就会变得相当容易。
我的office水平并不算很强，有很多简便的操作和函数对我来说仍是未知领域，VBA也只是入门水平，编译不通过或者运行出bug也是经常的事。为了努力提高自己的知识水平，我会不定期地写一些office操作的小手账，强化自身学习的同时，也和大家一起分享。水平粗浅，如有错漏或可以改进之处，欢迎大家提出
提示：这篇学习手账涉及编程，适合有一定编程基础的同志阅读
1
案例：合并多个工作簿
我们也许经常能遇到如下图所示的情况。
总是有一些令人生厌的数据源，明明放在一张表格里的事情，它偏要给你来上三五张表，甚至十几二十张表。有些表格还分Sheet来存放数据。
这个案例里尚且只有3个工作簿总共不到10个工作表，在数据量大的情况下可能会有几十张表，手动复制粘贴怕是会粘到头皮发麻。
有时候粘贴完了还不够，还要分部门/分人头将表格拆分，以分别发送给相应人员。如果要拆分很多次的话……
这一期我们使用VBA来将这些表格一键整合到一起，同时一键将一个工作簿中的不同工作表分别另存。
2
撰写打开工作簿并复制其内容的代码
这个代码的核心思路很简单：打开已有的工作簿文件，复制工作簿的每个工作表，粘贴到当前的工作簿之中。
新建一个工作簿之后，首先想办法打开已有的工作簿。VBA对于打开工作簿文件的理解是：给它一个工作簿地址的字符串，然后解析这个字符串地址来打开工作簿。可以使用Application.GetOpenFilename方法，调用打开文件的窗口，获取要打开的工作簿所在地址。这个方法的一般使用形式如下：
Application.GetOpenFilename([FileFilter/文件类型过滤器], [FilterIndex/过滤器索引], [Title/标题], [ButtonText/按钮文本(仅限MAC系统)], [MultiSelect/是否多选])
我们一般用到的就是FileFilter，Title和MultiSelect三个参数。FileFilter是一个字符串，VBA会自动解析其中的星号、逗号、分号等字符，从而在打开文件的对话框中指定文件类型。
'注意这里的Variant类型：如果要判断是否选择了文件(即是否在弹出的对话框中点了关闭或取消按钮)，就要设置Variant类型。
'定义File作为单个文件的地址，Filename作为文件地址的集合。
Dim File As Variant, Filename As Variant
Filename = Application.GetOpenFilename(FileFilter:="Excel工作簿文件, *.xls;*.xlsx;*.xlsm;*.csv", Title:="请选择您要复制的工作簿", MultiSelect:=True)
实现的效果如下图所示。
选择这三个工作簿之后按“打开”，这三个工作簿的地址就会输入到Filename变量中。如果点击右上角的“×”或右下角的“取消”，则会返回一个False逻辑值到Filename变量中。如果定义Filename的变量类型是字符串型，程序就会报错，而如果定义的变量类型是Variant则程序会继续进行。
为了不因为误点“取消”或“×”导致程序出错，我们加一个小小的错误处理子过程。
'该子过程用于点击“取消”时退出程序
Private Sub EXITPROGRAM()
    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳矩阵核心提示"
    'End关键字可直接终止主程序。
    End
End Sub
(关于MsgBox函数可参阅上期推文)
判断点了“取消”和“×”的方法也很简单。由于点了这两个按钮之后对话框会返回False值，而这是一个逻辑(Boolean)值，而不点这两个按钮意味着选择了文件(不选择文件是不能点击“打开”的)、对话框返回字符串值，因此使用VarType函数判定返回的值类型即可：
'如果If...Then...在一行内编写完成，则不需要End If
If VarType(Filename) = vbBoolean Then EXITPROGRAM
我们需要将代码所在的工作簿和需要复制的工作簿圈定下来，以确保复制的目标不会跑错。
'可以直接将变量定义为对象(Workbook，Worksheet等)
Dim ThisWB As Workbook, CopyWB As Workbook
'给对象类型的变量“赋值”，要使用Set关键字
'ThisWorkbook代表代码所在的工作簿
Set ThisWB = ThisWorkbook
接下来我们从文件名中循环读取每一个工作簿，并复制其中的内容。由于Filename变量中存储了三个文件名，相当于一个数组类型的变量，因此我们可以采取For Each ... Next这样的数组循环。
对于每个文件名，我们都要进行“解析”，来获取正确的对象。我们可以使用GetObject函数来实现。GetObject函数的用法为：
GetObject([路径/PathName], [对象类型/Class])
VBA能自动识别工作簿等内置的类别，因此在本例中我们可以直接省略Class参数。至于路径参数，就是Filename中的每一个路径文本串了。
我们知道，所有的工作簿下面都有若干个工作表。我们可以简单地使用Count方法来获取工作簿下面有多少个工作表，然后使用Copy方法来复制工作表。Copy方法的用法为：
Worksheet.Copy [放在某表之前/Before], [放在某表之后/After]
对一个工作表执行Copy命令后，Excel就会自动生成一张工作表，放在指定的工作表之前/之后(这个工作表可以是任意一个工作簿中的)。如果省略了Before和After参数，那么Excel就会自动建立一个新的空白工作簿并插入这个复制的工作表。
执行完命令之后要关闭工作簿，使用工作簿的Close方法关闭(否则我们想粘贴几个工作簿的内容，执行完成后就会有几个工作簿的窗口)。Close方法的用法为：
Workbook.Close [是否保存/SaveChanges], [保存更改后的文件名/Filename], [发送工作簿/RouteWorkbook]
我们不需要保存工作簿，也不需要发送工作簿，因此将第一个参数设置为False即可。本段代码整合后如下所示：
'File和Filename都是Variant变量，因此其可以作为Filename集合的一个元素参与循环，不需要预先给File定义值。
'类似的还有Workbook和Workbooks、Worksheet和Worksheets等
For Each File In Filename
    Set CopyWB = GetObject(File)
    For i = 1 To CopyWB.Worksheets.Count Step 1
        'Sheets(i)代表标签序号为i的工作表
        '特别注意：请务必思考清楚所需要的工作表顺序
        CopyWB.Sheets(i).Copy After:=ThisWB.Sheets(1)
        '工作表在复制时会复制原有的名称，如果与已有工作表重名则会发生错误导致程序停止。使用On Error Resume Next来跳过错误，此时Excel会自动对重名的工作表重新命名。
        On Error Resume Next
    Next i
    'False针对的是Close方法的第一个参数，因此可以直接不写参数名。
    CopyWB.Close False
Next File
整合后的代码如下所示。
'该子过程用于点击“取消”时退出程序
Private Sub EXITPROGRAM()
    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳探机的提示"
    End
End Sub
'主程序
Sub 复制指定工作簿的所有工作表()
    'Chr(13)代表换行符
    MsgBox "本程序将打开若干工作簿，" & Chr(13) & "复制其中的所有工作表并插入本工作簿。", vbOKOnly + vbInformation, "太阳探机的提示"
    MsgBox "请选择您要复制的工作簿。", vbOKOnly + vbInformation, "太阳探机的提示"
    Dim File As Variant, Filename As Variant, ThisWB As Workbook, CopyWB As Workbook, i&
    Filename = Application.GetOpenFilename(FileFilter:="Excel工作簿文件, *.xls;*.xlsx;*.xlsm;*.csv", Title:="请选择您要复制的工作簿", MultiSelect:=True)
    If VarType(Filename) = vbBoolean Then EXITPROGRAM
    '设置DisplayAlerts为False来跳过工作表重名的确认环节
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set ThisWB = ThisWorkbook
    For Each File In Filename
        Set CopyWB = GetObject(File)
        For i = 1 To CopyWB.Worksheets.Count Step 1
            CopyWB.Sheets(i).Copy After:=ThisWB.Sheets(1)
            On Error Resume Next
        Next i
        CopyWB.Close False
    Next File
    '不重新开启ScreenUpdating的话，下面的MsgBox语句将无法出现执行效果
    Application.ScreenUpdating = True
    MsgBox "已成功完成工作表的复制。", vbOKOnly + vbInformation, "太阳探机的提示"
End Sub
实际执行一下。等待若干秒以后(时间主要浪费在重复的打开、关闭工作簿的操作中)，即可发现所有工作表都已经转入到了我们新建的工作簿中。
接下来执行第二步：将其它工作表中的数据转移到活动的工作表中。
3
复制其它工作表的内容到一张工作表中
这一步比刚才更加简单。在上面的操作中，我们把所有的工作表都放在了这个工作簿自带的工作表(Sheet1)之后，因此只需要跳转回第一个工作表，再执行代码将其它工作表的内容复制过来即可。只需要很简单的代码即可完成：
Sub 复制所有工作表到特定表()
    Application.ScreenUpdating = False
    Dim i&
    For i = 2 To ThisWorkbook.Worksheets.Count Step 1
        '通过EntireRow来选中整行。这样做是为了避免复制时，由于各工作表的列数不统一导致出现错位的情况。
        '例如，表1有5列，但表2只有4列。如果不选中整行将表2复制到表1的话，那么插入复制的单元格时，如果指定活动单元格下移，就只有前4列会下移，而第5列会不动，从而产生错位。
        Sheets(i).UsedRange.EntireRow.Copy
        ThisWorkbook.ActiveSheet.Rows(1).Insert
    Next i
    Application.ScreenUpdating = True
    MsgBox "已从其它工作表中复制所有内容到活动工作表。", vbOKOnly + vbInformation, "太阳探机的提示"
End Sub
执行之后的效果如图所示：
再写一个更简单的代码，删除多余的表头：
Sub 删除多余表头()
    Dim i&
    '这里的循环是从最后一行往上走的，各位可以想一想为什么要这样走
    For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
        '整行删除之后，下方的单元格会上移
        If Cells(i, 1).Value = "工号" Then Rows(i).EntireRow.Delete
    Next i
    MsgBox "已删除多余表头。", vbOKOnly + vbInformation, "太阳探机的提示"
End Sub
执行的效果如下：
再写一个最简单的代码，删除其它的无用表格：
Sub 删除无用表格()
    Dim i&
    '关闭DisplayAlerts来避免重复确认。注意：工作表删除后不可撤销，请谨慎处理。
    Application.DisplayAlerts = False
    If ThisWorkbook.Worksheets.Count > 1 Then
        '这里的循环也是从最后一个往前走的，各位可以想一想为什么要这样走
        For i = ThisWorkbook.Worksheets.Count To 2 Step -1
            ThisWorkbook.Sheets(i).Delete
        Next i
        MsgBox "已删除多余的表格。", vbOKOnly + vbInformation, "太阳探机的提示"
    Else
        MsgBox "没有多余的表格。", vbOKOnly + vbExclamation, "太阳探机的提示"
    End If
End Sub
执行的效果：
如果在只有一个工作表的情况下运行，则会弹出提示信息：
是不是很完美？别急，更完美的还在下面~
4
分别保存每个工作表的内容
假设在上面这张表中，我们需要将表按照部门拆分，分别保存。拆分的过程这里略过(可以用VBA实现，欢迎大家思考)，表如图所示：
其思想非常简单。我们之前有提到，Worksheet的Copy方法如果省略了Before和After参数，那么Excel就会自动建立一个新的空白工作簿并插入这个复制的工作表。我们可以灵活运用这一点，并使用Application.Dialogs属性的Show方法来弹出“另存为”对话框，供选择保存路径。代码如下：
'该子过程用于点击“取消”时退出程序
Private Sub EXITPROGRAM()
    MsgBox "您取消了程序。程序结束。", vbOKOnly + vbExclamation, "太阳探机的提示"
    End
End Sub
Sub 将工作表分别另存()
    Dim i&, Response As Variant
    For i = 1 To ThisWorkbook.Worksheets.Count Step 1
        ThisWorkbook.Sheets(i).Copy
        'Show方法会弹出“另存为”对话框。弹出对话框时可以查看工作簿的内容以及下方的标签，以防忘记当前保存的工作簿。
        Response = Application.Dialogs(xlDialogSaveAs).Show
        If Response = False Then
            ActiveWorkbook.Close False
            EXITPROGRAM
        End If
    ActiveWorkbook.Close False
    Next i
    MsgBox "已将所有" & ThisWorkbook.Worksheets.Count & "个工作表另存。", vbOKOnly + vbInformation, "太阳探机的提示"
End Sub
实现的效果如图所示：
5
本章使用到的方法、函数汇总
Application.GetOpenFilename方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.application.getopenfilename
GetObject函数：https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/getobject-function
Worksheet.Copy方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.worksheet.copy
Workbook.Close方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.workbook.close
VarType函数：https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/vartype-function
Range.Copy方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.copy
Range.Insert(Rows、Columns其实都属于Range对象)方法：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.insert
Application.Dialogs属性：https://docs.microsoft.com/zh-cn/office/vba/api/excel.application.dialogs
另可参考：
Range.PasteSpecial方法(可执行行列转置、保留源列宽等特殊粘贴操作)：https://docs.microsoft.com/zh-cn/office/vba/api/excel.range.pastespecial
▼
学好VBA
走遍天下都不怕
▶THE END◀
太阳矩阵核心
一颗人工恒星
真的很厉害哦
不扫一扫关注一下吗
根据微信政策，从今年3月起，所有新开的微信公众号都将暂时不开放留言功能，具体什么时候再开放是个未知数。想要留言的小伙伴们，欢迎在后台留言嘿~
	

Sub shishi()

   Dim ad As String

 ad = GetFileName("a\20201602.xlss")

MsgBox (ad)

End Sub



Function GetFileName(ByVal sName As String)

    '获取纯文件名的自定义函数

    Dim sTemp As String

    sTemp = sName

    '判断后缀名分隔符.的位置

    iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")

    If iPos <> 0 Then

        sTemp = Mid(sTemp, 1, iPos)

    End If

   ' MsgBox (sTemp)

    '判断路径分隔符\的位置

    iPos = VBA.InStr(1, sTemp, "\")

    If iPos <> 0 Then

        '反转后好取字符

        iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")

        MsgBox (sTemp)

        sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)

        sTemp = VBA.StrReverse(sTemp)

    End If

    GetFileName = sTemp

End Function

近日在工作中常常遇到需要将多个工作薄中的工作表合并到一张工作表里，手动打开每个工作薄复制里面的内容然后粘贴进同一张表里非常麻烦，最近在学习vba，所以自己练习写了一段代码以简化工作。（为了防止自己忘记python，工作中遇到的问题用vba实现了以后，也会全部用python实现一遍，本文也对python实现文件合并的代码做了解释）
vba实现文件合并有两个重要的知识点：1. 使用dir函数读取每个文件的文件名  2.使用工作表函数counta()获取单元格使用区域的最大行数和列数  （注：counta()只能获取非空单元格的数量，所以使用counta()计算时的作为其参数的行或列必须没有空值，这样才能准确计算数据区域的最大行列数）
获取vba单元格使用区域最大行数和列数的方法还有：sheet1.Range(“A65536”).End(x1up). row
sheet1.Range(“IV1”).End(x1toleft). column
但是以上代码我在运行时报错（具体原因未明）
另外，在其他人的分享里也有看到使用sheet1. usedrange.rows.count
sheet1.usedrange.columns.count
来获取已使用的单元格的最大行数和列数，这个获取出来的行列数有可能会比工作表现有数据区域的行列数要大，因为它获取的是使用过的单元格区域最大行列数，如果工作表的数据区域有过删除行操作，那么它返回的还是删除之前的行列数。
下面介绍一下dir()的用法:str=dir（"D:data*.*"）
str=dir
如上所示，参数是工作簿存储的路径，使用*通配符可以获得D盘data文件夹下所有文件（如果你有别的需求可以自己改成*.xls,*.csv,*.xls*等）第一行代码返回文件夹下第一个文件的名称，第2行代码返回第二个文件的名称，继续使用str=dir可以继续获取后面的文件的名称，直到str返回为空，则说明所有文件的名字都已经遍历过了，再继续使用str=dir则程序会报错。
vba具体实现如下：
m1,m2是打开的EXCEL文件的行数和列数；n是编写宏的这个工作簿中的表的当前的行数。
另外，为什么使用counta()而不使用count()来对单元格计数？counta()计算非空单元格的个数，无论单元格的值是文本数据、数值数据或日期数据，使用counta（）都会计算进来；但是count（）只计算数值型数据的单元格个数。
python实现代码如下：
python实现主要使用os模块下listdir()函数，这个函数可以将当前路径下的所有文件的文件名以列表的形式返回（当然，首先要使用os模块下的chdir()跳转到需合并的文件的文件路径下）；最后合并文件使用pandas模块下的concat（）函数。