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 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

三、文件下载