提取文件名--VBA代码分享

提取文件名的VBA代码分享，以下为代码及使用方法

（对于需要使用VBA来调用窗口打开文件对话框，选择文件或文件夹，可参考代码修改，服务于自身需求。）

使用方法 （VBA入门教程）

1，新建一个Excel工作簿，另存为.xlsm格式。（office2016版.xlsx格式不支持运行宏，xlsm格式是支持运行宏的文件格式。）

2，点击 开发工具，点击 Visual Basic 打开代码编辑器，双击Sheet1，复制代码，保存。

如果找不到开发工具，则去 Excel选项设置中勾选开发工具。（路径为：文件--更多--选项--自定义功能区--主选项卡--开发工具）

3，点击 开发工具，点击插入，插入 Active X控件 ，选择第一个长方形控件，在空白处绘制控件。（在E列之后，E列之前会挡住文件名数据）绘制好控件后，关闭 设计模式 。（插入控件后会自动开启 设计模式），点击 绘制的好的控件，即可运行程序。

4，或者不绘制控件（即 不进行第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

（如有代码使用问题或报错，请留言。）