VBA获取文件夹下所有文件名或者文件夹名
1，新建excel宏
2，在sheet中添加宏执行按钮
3，设置按钮执行的代码名
VBA代码如下：
`
点击查看代码
'选择文件按钮程序
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Call Choose
Application.ScreenUpdating = True
End Sub
'文件或文件夹选择程序
Sub Choose()
Dim Value%
Value = MsgBox("选择 文件 还是 文件夹 ？" & Chr(10) & Chr(10) & "是，选择文件" & Chr(10) & "否，选择文件夹", vbYesNoCancel + vbQuestion + vbDefaultButton1, "请选择")
If Value = vbYes Then
Call FilePicker
ElseIf Value = vbNo Then
Call FolderPicker
Else
End
End If
End Sub
'选择文件程序（选择文件的方式提取文件名程序）
Sub FilePicker()
Dim i&, Item, Rng
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择文件"
.ButtonName = "确定"
If .Show = -1 Then
ReDim Item(1 To .SelectedItems.Count, 1 To 5)
For i = 1 To .SelectedItems.Count
Item(i, 1) = i
Item(i, 2) = .SelectedItems(i)
Next
Else
Exit Sub
End If
End With
Entering Item
End Sub
'选择文件夹程序（选择文件夹的方式提取文件名程序）
Sub FolderPicker()
Dim Path$, i&, j&, Item, arr(), Rng, iFSO, iFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择文件夹"
.ButtonName = "确定"
If .Show = -1 Then
Path = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\")
Else
Exit Sub
End If
End With
Set iFSO = CreateObject("Scripting.FileSystemObject")
Set iFolder = iFSO.GetFolder(Path)
i = 1
ReDim Preserve arr(1 To 1000)
GetAllFiles iFolder, arr, i
ReDim Item(1 To UBound(arr), 1 To 5)
For j = 1 To UBound(arr)
If arr(j) <> "" Then
Item(j, 1) = j
Item(j, 2) = arr(j)
Else
Exit For
End If
Next
Entering Item
End Sub
'遍历文件夹提取文件名程序
Sub GetAllFiles(ByVal iFolder, arr, i&)
Dim iFile, iSubFolder
For Each iFile In iFolder.Files
If i > UBound(arr) Then ReDim Preserve arr(1 To 1000 + i)
arr(i) = iFile.Path
i = i + 1
Next
If iFolder.SubFolders.Count = 0 Then Exit Sub
For Each iSubFolder In iFolder.SubFolders
GetAllFiles iSubFolder, arr, i
Next
End Sub
'文件名录入程序
Sub Entering(ByVal Item)
On Error Resume Next
Dim Rng, i&
For i = 1 To UBound(Item)
Item(i, 3) = Right(Item(i, 2), Len(Item(i, 2)) - InStrRev(Item(i, 2), "\")) '文件名带后缀
Item(i, 4) = Left(Item(i, 3), InStrRev(Item(i, 3), ".") - 1) '文件名不带后缀
Item(i, 5) = Right(Item(i, 2), Len(Item(i, 2)) - InStrRev(Item(i, 2), ".") + 1) '文件后缀
Next
Range("A1").Resize(UBound(Item), 5) = Item '文件名录入
End Sub
`
把上面代码添加到宏中，设置按钮，就可以获取文件夹名，或者文件夹下所有文件名
