如果需要对用户指定的文件进行操作，可以使用GetOpenFilename方法打开Excel内置的【打开】对话框，获取用户选择的文件名，此过程并不需要真正打开文件，示例代码如下。
 
Sub SelectFile()
     Dim vntFilename As Variant
     Dim i As Integer
     vntFilename = Application.GetOpenFilename(Title:="浏览文件", _
         FileFilter:="所有文件 (*.*),*.*,Excel文件 (*.xls*),*.xls*", _
         FilterIndex:=2, MultiSelect:=True)
     If IsArray(vntFilename) = True Then'判断是否为数组
         With Sheet1
             .Cells.ClearContents
             .Cells(1, 1) = "文件名"
             For i = 1 To UBound(vntFilename)
                 .Cells(i + 1, 1) = vntFilename(i)
             Next i
         End With
     End If
 End Sub
 
第4行代码使用Application对象的GetOpenFilename方法打开Excel内置的【打开】对话框，供用户选择文件并将选择的文件名赋值给vntFilename，其语法格式如下。
 
GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
 
各参数说明如下。
 
名称
必选/可选
数据类型
说明
FileFilter
可选
Variant
一个指定文件筛选条件的字符串。由文件筛选字符串和通配符文件筛选规范组成，多个筛选条件之间用逗号隔开。如果省略则默认值为"所有文件(*.*)"。并且是成对存在，前一个是筛选类型描述，后一个是筛选规则
FilterIndex
可选
Variant
指定默认文件筛选条件的索引号，取值范围为 1 到由 FileFilter  所指定的筛选条件数目。如果省略该参数，或者该参数的值大于可用筛选条件数，则使用第一个文件筛选条件。即对话框右下角的文件筛选类型。
Title
可选
Variant
指定对话框的标题。如果省略该参数，则标题为“打开”。
ButtonText
可选
Variant
仅用于Macintosh。
MultiSelect
可选
Variant
如果为 True，则允许选择多个文件名。如果为  False，则只允许选择一个文件名。默认值为 False。
GetOpenFilename方法的返回值是一个包含所有选定文件名及文件路径的数组。
 
如果用户单击对话框中的【取消】按钮或【关闭】按钮，则返回值为False。
 
第11行代码中的UBound函数返回指定数组维的上界。
 
 
 
 

微信公众号：VBA168
 
淘宝店铺地址：https://item.taobao.com/item.htm?spm=a1z10.1-c-s.w4004-21233576391.4.1af0683dzrx3oU&id=584940166162
 
关注微信公众号，每天及时接收Excel VBA经典示例讲解。
 
淘宝店铺提供Excel定制服务。
 
祝你工作和学习更轻松！

Sub shishi()
    Dim ad As String
  ad = GetFileName("a\20201602.xlss")
 MsgBox (ad)
 
End Sub
 

 Function GetFileName(ByVal sName As String)
     '获取纯文件名的自定义函数
     Dim sTemp As String
     sTemp = sName
     '判断后缀名分隔符.的位置
     iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")
     If iPos <> 0 Then
         sTemp = Mid(sTemp, 1, iPos)
     End If
    ' MsgBox (sTemp)
     '判断路径分隔符\的位置
     iPos = VBA.InStr(1, sTemp, "\")
     If iPos <> 0 Then
         '反转后好取字符
         iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")
         MsgBox (sTemp)
         sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)
         sTemp = VBA.StrReverse(sTemp)
     End If
     GetFileName = sTemp
 End Function

一、设计思路
 
1.选择要修改文件的文件夹；
 
2.获取文件夹内所有文件；
 
3.在Excel里面将文件改后名写好；
 
4.更改文件名；
 
5.清空数据；
 
 
 二、代码实现
 
1.可视化选择文件夹代码
 
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With
 
2.获取文件夹内所有文件列表函数
 
Function qh_get_all_file_fun(Optional qh_mypath0)    '获取文件夹内所有文件列表   作者：阙辉   20210429
Dim qh_myfso As Object
Dim qh_mypath
Dim qh_myfile
Dim qh_FolderName
Dim qh_myfile_count As Long
Dim qh_myfile_array
Dim qh_i As Long

On Error Resume Next

qh_mypath = qh_mypath0      '路径 阙

'路径为空则取文件同一文件夹 阙
If qh_mypath = "" Then
    qh_mypath = ThisWorkbook.Path '& "\" & qh_FolderName
Else
    qh_mypath = qh_mypath
End If

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")
'获取文件  阙
Set qh_myfile = qh_myfso.GetFolder(qh_mypath).Files
'获取文件数量
qh_myfile_count = qh_myfso.GetFolder(qh_mypath).Files.Count

'重定义数组 阙
ReDim qh_myfile_array(1 To qh_myfile_count)
'将文件名存储数组  阙
qh_i = 1
For Each qh_sh In qh_myfile
    qh_myfile_array(qh_i) = qh_sh.Name
    qh_i = qh_i + 1
'    MsgBox qh_myfso.GetExtensionName(qh_mypath & "\" & qh_sh.Name)   获取文件拓展名
Next

qh_get_all_file_fun = Array(qh_myfile_array, qh_myfile_count)
'输出数组：0 文件列表，1文件数量

End Function
 
3.获取文件列表主程序代码
 
Sub qh_get_all_file_sub(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

On Error Resume Next
Dim qh_xu
Dim qh_file_count As Long
'aa = Application.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With

qh_file_array = qh_get_all_file_fun(qh_select_path)
qh_file_count = qh_file_array(1)
qh_file_array0 = qh_file_array(0)
qh_file_count_00 = qh_file_count

ReDim qh_xu(1 To qh_file_count)

For qh_i = 1 To qh_file_count
    qh_xu(qh_i) = qh_i
Next

With Sheets(1)
    .Range("A5").Resize(qh_file_count) = Application.Transpose(qh_xu)
    .Range("B5").Resize(qh_file_count) = Application.Transpose(qh_file_array0)
End With

End Sub
 
4.修改文件名主程序代码
 
Sub qh_update_file_name(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

If qh_path_oo = "" Or qh_file_count_00 = "" Then
    MsgBox "请重新运行'获取文件'，QH!"
    Exit Sub
End If

qh_count = qh_file_count_00 + 5 - 1

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")

With Sheets("QH_文件修改")
For qh_i = 5 To qh_count
    qh_old_name = qh_path_oo & "\" & .Cells(qh_i, 2)
    qh_HouZhuiMing = qh_myfso.GetExtensionName(qh_old_name)
    qh_new_name0 = .Cells(qh_i, 3)
    qh_new_name = qh_path_oo & "\" & qh_new_name0 & "." & qh_HouZhuiMing
    On Error Resume Next
'    On Error GoTo QH_ERROR1
    
    '如果改名称为空则不执行修改  日志报修改失败
    If qh_new_name0 <> "" Then
        Name qh_old_name As qh_new_name
        qh_KongBai = False
    Else
        '空白 qh_KongBai则为真
        qh_KongBai = True
    End If
    If qh_myfso.FileExists(qh_new_name) Then
        .Cells(qh_i, 4) = "修改成功,QH！"
        .Cells(qh_i, 5) = .Cells(qh_i, 3) & "." & qh_HouZhuiMing
    ElseIf qh_KongBai Then
        .Cells(qh_i, 4) = "改文件名（新）不能为空,QH！"
        .Cells(qh_i, 5) = ""
    Else
        .Cells(qh_i, 4) = "修改失败,QH！"
        .Cells(qh_i, 5) = ""
    End If
Next
'Exit Sub
'QH_ERROR1:
'
'Resume Next
End With
End Sub
 
5.清空数据调用程序代码
 
Sub qh_clear_data(quehui)
If quehui <> "QH" Then
    Exit Sub
End If
With Sheets("QH_文件修改")
    .Range("A5:E100000").ClearContents
End With
End Sub
 
6.完整代码
 
Public qh_path_oo   '定义公共变量
Public qh_file_count_00   '定义公共变量
Function qh_get_all_file_fun(Optional qh_mypath0)    '获取文件夹内所有文件列表   作者：阙辉   20210429
Dim qh_myfso As Object
Dim qh_mypath
Dim qh_myfile
Dim qh_FolderName
Dim qh_myfile_count As Long
Dim qh_myfile_array
Dim qh_i As Long

On Error Resume Next

qh_mypath = qh_mypath0      '路径 阙

'路径为空则取文件同一文件夹 阙
If qh_mypath = "" Then
    qh_mypath = ThisWorkbook.Path '& "\" & qh_FolderName
Else
    qh_mypath = qh_mypath
End If

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")
'获取文件  阙
Set qh_myfile = qh_myfso.GetFolder(qh_mypath).Files
'获取文件数量
qh_myfile_count = qh_myfso.GetFolder(qh_mypath).Files.Count

'重定义数组 阙
ReDim qh_myfile_array(1 To qh_myfile_count)
'将文件名存储数组  阙
qh_i = 1
For Each qh_sh In qh_myfile
    qh_myfile_array(qh_i) = qh_sh.Name
    qh_i = qh_i + 1
'    MsgBox qh_myfso.GetExtensionName(qh_mypath & "\" & qh_sh.Name)   获取文件拓展名
Next

qh_get_all_file_fun = Array(qh_myfile_array, qh_myfile_count)
'输出数组：0 文件列表，1文件数量

End Function
Sub qh_get_all_file_sub(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

On Error Resume Next
Dim qh_xu
Dim qh_file_count As Long
'aa = Application.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        qh_select_path = .SelectedItems(1)
        qh_path_oo = .SelectedItems(1)
    End If
End With

qh_file_array = qh_get_all_file_fun(qh_select_path)
qh_file_count = qh_file_array(1)
qh_file_array0 = qh_file_array(0)
qh_file_count_00 = qh_file_count

ReDim qh_xu(1 To qh_file_count)

For qh_i = 1 To qh_file_count
    qh_xu(qh_i) = qh_i
Next

With Sheets(1)
    .Range("A5").Resize(qh_file_count) = Application.Transpose(qh_xu)
    .Range("B5").Resize(qh_file_count) = Application.Transpose(qh_file_array0)
End With

End Sub
Sub qh_update_file_name(quehui)
If quehui <> "QH" Then
    Exit Sub
End If

If qh_path_oo = "" Or qh_file_count_00 = "" Then
    MsgBox "请重新运行'获取文件'，QH!"
    Exit Sub
End If

qh_count = qh_file_count_00 + 5 - 1

'实例化对象 阙
Set qh_myfso = CreateObject("Scripting.FileSystemObject")

With Sheets("QH_文件修改")
For qh_i = 5 To qh_count
    qh_old_name = qh_path_oo & "\" & .Cells(qh_i, 2)
    qh_HouZhuiMing = qh_myfso.GetExtensionName(qh_old_name)
    qh_new_name0 = .Cells(qh_i, 3)
    qh_new_name = qh_path_oo & "\" & qh_new_name0 & "." & qh_HouZhuiMing
    On Error Resume Next
'    On Error GoTo QH_ERROR1
    
    '如果改名称为空则不执行修改  日志报修改失败
    If qh_new_name0 <> "" Then
        Name qh_old_name As qh_new_name
        qh_KongBai = False
    Else
        '空白 qh_KongBai则为真
        qh_KongBai = True
    End If
    If qh_myfso.FileExists(qh_new_name) Then
        .Cells(qh_i, 4) = "修改成功,QH！"
        .Cells(qh_i, 5) = .Cells(qh_i, 3) & "." & qh_HouZhuiMing
    ElseIf qh_KongBai Then
        .Cells(qh_i, 4) = "改文件名（新）不能为空,QH！"
        .Cells(qh_i, 5) = ""
    Else
        .Cells(qh_i, 4) = "修改失败,QH！"
        .Cells(qh_i, 5) = ""
    End If
Next
'Exit Sub
'QH_ERROR1:
'
'Resume Next
End With
End Sub
Sub qh_clear_data(quehui)
If quehui <> "QH" Then
    Exit Sub
End If
With Sheets("QH_文件修改")
    .Range("A5:E100000").ClearContents
End With
End Sub
 
三、文件下载
 
 

'保存工作簿时，如何后一个名称不和前一个名称重复？
 '有很多种方法，通常会以时间命名，比如我们手机里的照片的名称一般都会有时间，很多地方都是。
 '我们也可以这样命名，具体方法如下。
 
Sub 保存工作簿时命名()
    ThisWorkbook.SaveAs ThisWorkbook.Path & "\另存为工作簿" & Format(Now, "yyyymmddhhmmss")
End Sub
 
'这里用到了秒，这样命名时一般就不会重复，这是14位的，想要短一些的话，可以把前面的若干位省略。