Excel VBA批量修改文件名
一、设计思路
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 With2.获取文件夹内所有文件列表函数
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 Function3.获取文件列表主程序代码
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 Sub4.修改文件名主程序代码
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 Sub5.清空数据调用程序代码
Sub qh_clear_data(quehui)
If quehui <> "QH" Then
Exit Sub
End If
With Sheets("QH_文件修改")
.Range("A5:E100000").ClearContents
End With
End Sub6.完整代码
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
三、文件下载