批量读取文件名

'强制声明变量，如果程序中有未声明的变量，程序不会运行

Option Explicit

'产生输出工作表

Sub sheet_output()

'遍历当前工作簿下的工作表，如果存在“output”表，则清空该表所有单元格内容，如无则产生新的工作表“output”

Dim sh As Worksheet, F As Boolean

For Eachsh In ThisWorkbook.Worksheets

If = "output" Then

Sheets("output").Cells.Delete

F = True 'F变量赋值，布尔代数

Exit For '如果存在“output”表，则退出循环

Else

F = False

End If

Next

'如果没有“output”表，则新增该表

If Not F Then

= "output"

End If

ThisWorkbook.Sheets("output").Range("A1").Value = "搜索文件路径："

End Sub

'弹出文件夹窗口目标选择文件夹

Sub window_select()

Dim objShell, objFolder

'文件夹窗口选择

Set objShell = CreateObject("Shell.Application") '建立对象

Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0) '浏览对话框

If Not objFolder Is Nothing Then lj = objFolder.self.Path& "\" '如果所选文件夹非空，则定位到所选择的文件夹

Set objFolder = Nothing '销毁对象，释放内存

Set objShell = Nothing '销毁对象，释放内存

ThisWorkbook.Sheets("output").Range("A2").Value = lj

End Sub

'遍历文件夹及其子文件夹路径

Sub subfolder_list()

Dim lj As String

Dim n As Integer, j As Integer, i As Integer, k As Integer

Dim dic, ke, myname

'获取以上文件夹路径下的文件

n = ThisWorkbook.Sheets("output").Cells(Rows.Count, 1).End(xlUp).Row

If n = 1 Then

MsgBox "请在A列输入搜索文件路径（从第二行开始）后，重新运行"

Exit Sub

Else

For j = 2 To n

lj = ThisWorkbook.Sheets("output").Cells(j, 1).Value '文件夹路径

Set dic = CreateObject("Scripting.Dictionary") '创建一个字典对象Scripting.FileSystemObject类型:FileSystemObject主对象。包含用来创建、删除和获得有关信息，以及通常用来操作驱动器、文件夹和文件的方法和属性。

If j = 2 Then

dic.Add ("文件夹清单(包含子文件夹)："), ""

End If

dic.Add (lj), "" '增加键/条目对到Dictionary(增加lj对应的项为“”)

i = 0

Do While i

ke = dic.keys '开始遍历字典，把字典中存在的所有的关键字赋给变量ke。得到的是一个一维数组，下限为0，上限为d.Count-1

myname = Dir(ke(i), vbDirectory) '查找目录dir函数返回一个字符串String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。

Do Whilemyname<> ""

If myname<> "." And myname<> ".." Then '在任何一个目录（或者说文件夹）中，都有两个隐含目录："."表示当前目录，".."表示当前目录的上一级目录

If (GetAttr(ke(i) &myname) And vbDirectory) = vbDirectory Then '如果是次级目录And:同为真时为真,GetAttr()文件或目录属性vbDirectory目录属性代码为16 16 and 16 =16

dic.Add (ke(i) &myname& "\"), "" '就往字典中添加这个次级目录名作为一个条目

End If

End If

myname = Dir '继续遍历寻找

Loop

i = i + 1

Loop

k = ThisWorkbook.Sheets("output").Cells(Rows.Count, 2).End(xlUp).Row + 1

If j = 2 Then

k = k - 1

End If

Sheets("output").Cells(k, 2).Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)

Next j

End If

End Sub

'遍历文件夹—读取工作簿名称

Sub read_excel()

Dim Did, MyFileName, ke, n As Integer, i As Integer

Set Did = CreateObject("Scripting.Dictionary")

'获取以上文件夹路径下的文件

n = ThisWorkbook.Sheets("output").Cells(Rows.Count, 2).End(xlUp).Row

If n = 1 Then

MsgBox "未输入文件夹路径提取文件夹，请在B列，第2行开始输入所需提取文件名的文件夹路径，并以'\ '结尾"

Exit Sub

Else

Did.Add ("文件清单:"), "" '以查找D盘下所有EXCEL文件为例

For i = 2 To n

ke = ThisWorkbook.Sheets("output").Cells(i, 2).Value

MyFileName = Dir(ke& "*.xls")

Do While MyFileName<> ""

Did.Add (ke&MyFileName), ""