VBA获取某文件夹下所有文件和子文件目录的文件

【引用位置】 https://blog.csdn.net/pashine/article/details/42100237

'-------------------------------------------

'获取某文件夹下的所有Excel文件

'-------------------------------------------

Sub getExcelFile(sFolderPath As String)

On Error Resume Next

Dim f As String

Dim file() As String

Dim x

k = 1

ReDim file(1)

file(1) = sFolderPath &""

End Sub

'-------------------------------------------

'获取某文件夹下的所有文件和子目录下的文件

'-------------------------------------------

Sub getAllFile(sFolderPath As String)

'Columns(1).Delete

On Error Resume Next

Dim f As String

Dim file() As String

Dim i, k, x

x = 1

i = 1

k = 1

ReDim file(1 To i)

file(1) = sFolderPath &""

'-- 获得所有子目录

Do Until i >k

f = Dir(file(i), vbDirectory)

Do Until f = ""

If InStr(f, ".") = 0 Then

k = k + 1

ReDim Preserve file(1 To k)

file(k) = file(i) &f &""

End If

f = Dir

Loop

i = i + 1

Loop

'-- 获得所有子目录下的所有文件

For i = 1 To k

f = Dir(file(i) &" . ")'通配符 . 表示所有文件，*.xlsx Excel文件

Do Until f = ""

'Range("a" &x) = f

Range("a" &x).Hyperlinks.Add Anchor:=Range("a" &x), Address:=file(i) &f, TextToDisplay:=f

x = x + 1

f = Dir

Loop

Next

End Sub

excel中用vba实现自动提取文件夹内的文件名的方法如下：

1、新建一个vba宏脚本

2、写入如下代码：

Function GetFileList(FileSpec As String) As Variant

'   Returns an array of filenames that match FileSpec

'   If no matching files are found, it returns False

  Dim FileArray() As Variant

  Dim FileCount As Integer

  Dim FileName As String

  On Error GoTo NoFilesFound

  FileCount = 0

  FileName = Dir(FileSpec)

  If FileName = "" Then GoTo NoFilesFound

'   Loop until no more matching files are found

  Do While FileName <>""

      FileCount = FileCount + 1

      ReDim Preserve FileArray(1 To FileCount)

      FileArray(FileCount) = FileName

      FileName = Dir()

  Loop

  GetFileList = FileArray

  Exit Function

'   Error handler

NoFilesFound:

  GetFileList = False

End Function

3、传入文件路径就可以获取文件名到指定的excel表格中

4、结果：

提取当前文件夹下的文件名称并放在A列

Sub 按钮1_Click()

Application.ScreenUpdating = False

Set fso = CreateObject("scripting.filesystemobject")

Set ff = fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

ActiveSheet.UsedRange.ClearContents

a = 1

For Each f In ff.Files

Rem 如果不需要提取本代码文件名，可以增加if语句 if f.name<>thisworkbook.name then.....

Rem 如果值需要提取某类文件，需要对f.name的扩展名进行判断

Rem 个人感觉split取 扩展名：split（f.name,".")(ubound（split（f.name,".")）)，然后再判断，避免文件名还有其他“.”

Cells(a, 1) = f.Name '相对路径名

Cells(a, 2) = f '全路径名

a = a + 1

Next f

Application.ScreenUpdating = True

End Sub

---