VBA获取文件夹下所有文件名或者文件夹名

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
`

把上面代码添加到宏中，设置按钮，就可以获取文件夹名，或者文件夹下所有文件名