Excel VBA：批量对文件任意重命名（移动）

目录

一、普通VBA代码的问题

二、创建任意文件夹的思路

1.创建FSO对象【文件系统对象】

2.判断盘符是否存在

3.循环逐层判断文件夹

（1）不存在的文件夹路径存入数组

（2）倒着循环arr

（3）创建文件夹

（4）完成

三、创建任意多层文件夹示例代码

四、批量对文件任意重命名

1.整理新旧文件名

2.执行

3.示例代码

五、文件

---

一、普通VBA代码的问题

如果用Dir()方法和MkDir方法，一般只能在已经存在的文件夹内创建一层新的子文件夹。无法命名任意多层文件夹。

也就是说，如现在如果已经存在文件夹【E:\ABC】，才能创建【E:\ABC\DEF】；否则是不能直接创建后面的新文件夹的。

二、创建任意文件夹的思路

1.创建FSO对象【文件系统对象】

用FSO对象主要是因为它处理文件与文件夹更专业，里面有各种函数和方法，不需要自己通过Mkdir/Dir/Split等函数和方法慢慢构造路径；同时避免很多出错的可能。

2.判断盘符是否存在

比如给定需要创建的文件夹是

路径 = "E:\A\b/C\d/ef\g/h\i\j\k/m/n"

利用【FSO.DriveExists()】函数判断给定的路径对应的盘符【E:\】是否存在，如果盘符不存在，是不可能创建出给定文件夹的，此时直接即出程序；否则，继续向下执行程序。

3.循环逐层判断文件夹

关于如果创建多层文件夹，之前有写过一篇文章：

【VBA：用MkDir函数创建多层文件夹】http://t.csdn.cn/2YFUo当时用的VBA自带的Dir()和Mkdir函数，可以参考一下。

而本文用的是另一种方法——FSO对象，更加方便和保险，减少出错。

（1）不存在的文件夹路径存入数组

利用【FSO.FolderExists()】函数，从给定的完整路径开始，逐级向上判断第级文件夹路径是否存在。

判断流程：

第1次，判断【E:\A\b/C\d/ef\g/h\i\j\k/m/n】是否存在
第2次，判断【E:\A\b/C\d/ef\g/h\i\j\k/m】是否存在
第3次，判断【E:\A\b/C\d/ef\g/h\i\j\k】是否存在
……
第n次，判断【E:\A】是否存在

A.如果不存在，则装入一个动态数组arr中；

B.如果该级文件夹路径存在，则往上肯定都存在了，就不再向上一级父文件夹进行判断。

（2）倒着循环arr

即从上面记录文件夹路径的数组arr的最大下标开始循环，直到最小下标结束，步长-1。

因为我们创建文件夹，是要按下面箭头所示的顺序由下向上逐级来操作的：

​ 创建文件夹的秦顺序

（3）创建文件夹

用【FSO.CreateFolder】方法逐级创建文件夹

（4）完成

循环arr完成，多层文件夹创建完成

三、创建任意多层文件夹示例代码

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

四、批量对文件任意重命名

在上述创建多层文件夹的方法的基础上，咱们可以对已经存在的文件任意移动或重命名

操作方法：

1.整理新旧文件名

在Excel的【Sheet1】表格和A列写原文件完整路径，B列写新文件名的完整路径

注：第一行是标题不会算在内

2.执行

点击【Sheet1】表格里的【执 行】按钮，即可完成。

​ 运行方法

或者打开文件，在代码主程序处点击运行也一样。

3.示例代码

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

五、文件

链接: https://pan.baidu.com/s/1zKAlHsCTd8fU33cxMVgtGw?pwd=uhsi 提取码: uhsi 复制这段内容后打开百度网盘手机App，操作更方便哦

打开文件直接操作即可。