Excel VBA：批量对文件任意重命名（移动）_vba对文件夹内所有文件更改名称

Sub 创建任意文件目录主程序()
    Dim 路径 As String
    路径 = "E:\A\b/C\d/ef\g/h\i\j\k/m/n" '只要此处所写的路径的盘符【E:\】在电脑存在，就能创建成功
    Call fsoCreatAnyFolder(路径)
End Sub
Sub fsoCreatAnyFolder(路径)
    Dim FSO As Object
    Dim p As String
    Dim s As String
    Dim arr() As String
    Dim i As Integer
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    p = Replace(folderToCreate, "/", "\")
    
    If Not FSO.DriveExists(Left(p, 3)) Then
        Debug.Print "错误：盘符不存在！"
        Set FSO = Nothing
        Exit Sub
    End If
    
    s = p
    Do While Not FSO.FolderExists(s)
        i = i + 1
        ReDim Preserve arr(1 To i)
        arr(i) = s
        s = FSO.GetParentFolderName(s)
    Loop
    
    For i = UBound(arr) To LBound(arr) Step -1
        FSO.CreateFolder (arr(i))
        Debug.Print arr(i)
    Next
    
    Set FSO = Nothing
End Sub

Sub 重命名(原文件名 As String, 新文件名 As String)
    Dim FSO As Object
    Dim 原文件夹 As String
    Dim 新文件夹 As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Not FSO.FileExists(原文件名) Then Exit Sub
    
    If FSO.DriveExists(Left(新文件名, 3)) Then
        新文件夹 = Replace(新文件名, FSO.GetFileName(新文件名), "")
        If Not FSO.FolderExists(新文件夹) Then
            fsoCreatAnyFolder 新文件夹
        End If
        
        Name 原文件名 As 新文件名
    End If
    
    Set FSO = Nothing
End Sub
 
Sub fsoCreatAnyFolder(folderToCreate As String)
    Dim FSO As Object
    Dim p As String
    Dim s As String
    Dim arr() As String
    Dim i As Integer
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    p = Replace(folderToCreate, "/", "\")
    
    If Not FSO.DriveExists(Left(p, 3)) Then
        Debug.Print "错误：盘符不存在！"
        Set FSO = Nothing
        Exit Sub
    End If
    
    s = p
    Do While Not FSO.FolderExists(s)
        i = i + 1
        ReDim Preserve arr(1 To i)
        arr(i) = s
        s = FSO.GetParentFolderName(s)
    Loop
    
    For i = UBound(arr) To LBound(arr) Step -1
        FSO.CreateFolder (arr(i))
        Debug.Print arr(i)
    Next
    
    Set FSO = Nothing
End Sub
 
Rem 注意：
    '1. 此处以下是主程序，光标定位在主程序任何位置，点击运行即可
    '2. 新旧文件路径分别放在表格名为【Sheet1】的表格的【A列】和【B列】
    '3. 表格第一行为标题行，不算数据
    '4. 都必须为绝对路径，不可省略
Sub 批量重命名主程序()
    Dim arr
    Dim i As Long
    arr = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Value
    For i = LBound(arr, 1) + 1 To UBound(arr)
        Call 重命名(CStr(arr(i, 1)), CStr(arr(i, 2)))
        Debug.Print arr(i, 1), " 已经命名为 ", arr(i, 2)
    Next
    MsgBox Format(UBound(arr) - LBound(arr), "完成 共处理了0个文件")
End Sub