VBA案例系列～获取文件名并重命名

大家好，欢迎来到这里。我们来进行个小小的作业，获取文件名并重命名，如果是您，您会怎么做，逐个去命名，如果只是10来个，那还好。那如果是上百个上千个呢，那么头大了。怎么办？怎么办？您看了今天的分享文章之后，那就不需要烦恼了。我们今天呢，不说过多的理论，直接上干货。分享一段代码，这段代码的作用就是获取文件名称并对获取的文件名进行重命名。

如下图1所示，一个文件夹内包含多个文件，现在需要在每个文件前面增加前缀"2022"。以下是我们按照VBA的方式来完成获取文件名并重新命名。

首先，使用以下代码，将该文件夹内的文件名批量提取到sheet1工作表的A列。

其次，在B列使用函数公式或其它方式，填写A列文件名对应的新名字。本例中B2单元格输入以下公式="2022-"&A2，并向下复制填充，也就是在原来文件名的基础上，在文件名前面加“2022-”

最后，复制运行以下代码到VBA的模块中，再运行即可将A列旧的文件名修改为新的文件名。

随附代码：

Sub GetFileNames()

Dim Path As String, strName As String

Dim i As Integer

Path = getPath() '获取选中文件夹的路径

If Path = "" Then Exit Sub '如果用户为选择文件夹，则退出程序

Application.ScreenUpdating = False

With Sheet1.Columns(1)

.Clear

.NumberFormat = "@" '设置文本格式

End With

i = 1

Cells(i, 1) = "（原）文件名"

strName = Dir(Path & "*.*")

Do While strName <> ""

i = i + 1 '计数器

Cells(i, 1) = strName

strName = Dir() '调用dir函数但未带参数

Loop

Application.ScreenUpdating = True

MsgBox "恭喜您，获取文件名成功"

End Sub

Function getPath() As String

Dim Path As String

With Application.FileDialog(msoFileDialogFolderPicker) '选择一个文件夹

If .Show Then

Path = .SelectedItems(1)

Else '如未选中文件夹则退出

Exit Function

End If

End With

If Right(Path, 1) <> "" Then Path = Path & ""

getPath = Path

End Function

Sub ReName()

Dim arr, brr

Dim i As Integer, n As Integer, Path As String

Dim OldName As String, NewName As String

Dim strMsg As String

On Error Resume Next '忽略错误使程序继续运行

Path = getPath() '调用getPath函数过程，打开【文件浏览】对话框，允许用户选择的目标文件夹，并获取相关文件的路径。

If Path = "" Then Exit Sub

arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row) '将新老名称存入数组

ReDim brr(1 To UBound(arr), 1 To 1) '最终结果的数组

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For i = 2 To UBound(arr) '除标题行遍历数组

If arr(i, 2) <> "" Then

Err.Clear

OldName = Path & arr(i, 1) '旧路径名

NewName = Path & arr(i, 2) '新路径名

Name OldName As NewName '重命名

If Err.Number Then

brr(i, 1) = "失败"

n = n + 1

Else

brr(i, 1) = "成功"

End If

End If

Next

Columns(3).ClearContents

brr(1, 1) = "处理结果"

Range("c1").Resize(UBound(brr, 1)) = brr '处理结果写入Excel

Application.ScreenUpdating = True

Application.DisplayAlerts = True

strMsg = "处理完成。"

If n Then strMsg = strMsg & vbCrLf & "有" & n & "个文件重命名失败," & "需要核对新文件名是否存在重复。"

MsgBox strMsg

End Sub