VBA学习(14):给1000个文件重命名_vba多文件文件夹分别命名

如下图所示，一个文件夹内包含了大量文件，现在需要在每个文件前面增加前缀"星光牌-"

为了使代码更具有通用性，更方便大家使用，我们还是采用两步走的方式。

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

 
Sub GetlWbNames()
    Dim strPath As String, strName As String
    Dim k As Long
    strPath = getStrPath() '获取用户选中文件夹的路径
    If strPath = "" Then Exit Sub '如果用户为选择文件夹，则退出程序
    Application.ScreenUpdating = False
    With ActiveSheet.Columns(1)
        .Clear '清空A列
        .NumberFormat = "@" '设置文本格式
    End With
    k = 1
    Cells(k, 1) = "目录"
    strName = Dir(strPath & "*.*")
    Do While strName <> ""
        k = k + 1 '计数器
        Cells(k, 1) = strName
        strName = Dir() '第2次调用dir函数但未带参数
    Loop
    Application.ScreenUpdating = True
    MsgBox "OK"
End Sub
Function getStrPath() As String
    Dim strPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strPath = .SelectedItems(1)
        Else '如用户未选中文件夹则退出
            Exit Function
        End If
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    getStrPath = strPath
End Function

然后，在B列使用函数公式或其它方式，填写A列文件名对应的新名字。本例中B2单元格输入以下公式，并向下复制填充：

="星光牌-"&A2

公式运算结果如下图所示：

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

 
Sub ChangeNames()
    Dim rngData As Range, aData, aRes
    Dim i As Long, n As Long, strPath As String
    Dim strOldName As String, strNewName As String
    Dim strMsg As String
    On Error Resume Next '忽略错误使程序继续运行
    strPath = getStrPath() '获取文件夹路径
    If strPath = "" Then Exit Sub
    Set rngData = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    aData = rngData '数据存入数组
    ReDim aRes(1 To UBound(aData), 1 To 1) '结果数组
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = 2 To UBound(aData) '扣掉标题行遍历数组
        If aData(i, 2) <> "" Then
            Err.Clear
            strOldName = strPath & aData(i, 1) '旧路径名
            strNewName = strPath & aData(i, 2) '新路径名
            Name strOldName As strNewName '重命名
            If Err.Number Then
                aRes(i, 1) = "失败"
                n = n + 1
            Else
                aRes(i, 1) = "成功"
            End If
        End If
    Next
    Columns(3).ClearContents
    aRes(1, 1) = "处理结果"
    Range("c1").Resize(UBound(aRes, 1)) = aRes '处理结果写回Excel
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    strMsg = "处理完成。"
    If n Then strMsg = strMsg & vbCrLf & _
                "有" & n & "个文件重命名失败," & _
                "需核对新文件名是否有重复。"
    MsgBox strMsg
End Sub
 
Function getStrPath() As String
    Dim strPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strPath = .SelectedItems(1)
        Else '如用户为选中文件夹则退出
            Exit Function
        End If
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    getStrPath = strPath
End Function

第7至第8行代码调用getStrPath函数过程，打开【文件浏览】对话框，允许用户选择的目标文件夹，并获取相关文件的路径。

第9至第10行代码将A:B列的数据源数据存入数组aData。

第11行代码声明一个结果数组aRes，用于存放处理结果信息。

第14至第27行代码遍历数据源数组，把第1列的旧文件名重命名为第2列的新文件名。第20至第25行代码，采用试错法，将处理结果信息写入结果数组。

第28至第30行代码将结果数组写回当前工作表的C列。

第33至第37行代码使用MsgBox语句弹出消息框显示处理结果。

第40至第51行代码是getStrPath函数过程。

技术交流，软件开发，欢迎加微信xwlink1996 

---

作者其他作品：

VBA实战(Excel)(1)：提升运行速度

Ribbon第一节：控件大全

HTML实战(1)：新建一个HTML

VB.net实战(VSTO)：Excel插件的安装与卸载