先给大家看实例效果吧：

开始我们的制作过程啦。

首先新建EXCEL工作簿，在一个工作表中按照如下输入设置：

一： A2单元格输入文字：文件夹路径；C2单元格输入文字：读取文件名后，请设置好新文件名后再执行文件重命名操作

二： A3:C3合并单元格

三： A4:C4合并单元格，并输入分割线(主要考虑视觉效果及VBA运行排除空行)

四： A5单元格输入文字：遍历文件夹下所有文件名

五： B5单元格输入文字：文件类型

六： C5单元格输入文字：设置新文件名(默认为原名)

七： 按照下图步骤，将文末的代码复制写入模块中：

八： 选择A1单元格，在开发工具选项卡中，选择插入菜单中的按钮(窗体控件)，制作三个按钮控件，设置文字为初始化(选择指定名为“初始化”的宏)，读取文件名(选择指定名为“读取文件名”的宏)，文件改名(选择指定名为“文件重命名”的宏)。

九： 开始自由改名啦，体验一下自己的劳动成果吧。解放你的双手，大大提高效率。

如果喜欢，请点赞并关注一下。不想再动手的话，就私信我索要文档吧。

请把此文章分享给你的朋友们。

Sub 读取文件名()

ActiveSheet.Rows("6:10000").Select

Selection.Delete Shift:=xlUp

ActiveSheet.Range("A6").Select

With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False

If .Show = -1 Then

[a3] = .SelectedItems(1)

End If

End With

Dim myPath$, i%

myPath = Dir([a3] & "*.*")

Do While myPath <> ""

i = i + 1

Cells(i + 5, 1) = Left(myPath, InStrRev(myPath, ".") - 1)

Cells(i + 5, 2) = Mid(myPath, InStrRev(myPath, "."), 9)

Cells(i + 5, 3) = Left(myPath, InStrRev(myPath, ".") - 1)

myPath = Dir

Loop

End Sub

Sub 文件重命名()

filePath = [a3]

On Error Resume Next

n = 6

While Not IsEmpty(Cells(n, 1))

oldName = Cells(n, 1) & Cells(n, 2)

newNname = Cells(n, 3) & Cells(n, 2)

If Dir(filePath & "" & oldName) = "" Then

MsgBox "请重新读取文件名！"

Exit Sub

ElseIf n < ActiveSheet.Range("A" & Rows.Count).End(3).Row Then

Name filePath & "" & oldName As filePath & "" & newNname

ElseIf n = ActiveSheet.Range("A" & Rows.Count).End(3).Row Then

Name filePath & "" & oldName As filePath & "" & newNname

MsgBox "重命名成功"

ActiveWorkbook.Save

Exit Sub

End If

n = n + 1

Wend

End Sub

Sub 初始化()

Range("a3").Select

Selection.ClearContents

ActiveSheet.Rows("6:10000").Select

Selection.Delete Shift:=xlUp

ActiveSheet.Range("A6").Select

ActiveWorkbook.Save

End Sub