VBA: 批量重命名文件夹和文件名称

Exploring

发布于 2022-12-18 03:55:51

9.7K00

代码可运行

文章被收录于专栏：数据处理与编程实践数据处理与编程实践

运行总次数：0

代码可运行

文章背景： 在工作中，有时需要将一些文件名称修改成特定的名称，如果文件比较多的话，手动修改费时费力，下面通过VBA代码实现批量操作。

1 Name函数2 应用示例2.1 批量修改文件夹的名称2.2 批量修改文件的名称

1 Name函数

Name oldpathname As newpathname

重命名磁盘文件、目录或文件夹。

oldpathname Required. String expression that specifies the existing file name and location; may include directory or folder, and drive.
Required. String expression that specifies the new file name and location; may include directory or folder, and drive. The file name specified by newpathname can't already exist.

（1）Name 语句重命名文件，并在必要时将其移动到其他目录或文件夹。Name 可以在驱动器之间移动文件，但只有当 newpathname 和 oldpathname 位于同一驱动器上时，它才能重命名现有目录或文件夹。Name 无法创建新文件、目录或文件夹。

（2）Using Name on an open file produces an error. You must close an open file before renaming it. Name arguments cannot include multiple-character (*) and single-character (?) wildcards.

2 应用示例

假设要把test文件夹内所有文件（包括子文件夹）名称中的SH改为NB。

2.1 批量修改文件夹的名称

(1) 获取所有子文件夹

表1 复制文件夹：

Option Explicit

Sub getSubFolderName()

    '给定父文件夹名称，获取全部子文件夹名称
    
    Dim folder As String, ii As Integer, arr() As String, tar_sheet As Worksheet
    
    Dim fso As Object, fld As Object, subfld As Object
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set tar_sheet = ThisWorkbook.Worksheets("1 复制文件夹")
    
    folder = tar_sheet.Range("B1").Value2
    
    ii = 0
    
    If fso.FolderExists(folder) Then
    
        Set fld = fso.getFolder(folder)
    
        For Each subfld In fld.subFolders
        
            If subfld.name Like "SH*" Then
            
                ii = ii + 1
                
                ReDim Preserve arr(1 To ii)
                
                arr(ii) = subfld.name
            
            End If
    
        Next
    
    Else
    
        MsgBox "父文件夹不存在，请检查！"
                
        Exit Sub
    
    End If
    
    If ii > 0 Then
    
        tar_sheet.Range("A4").Resize(ii, 1) = Application.Transpose(arr)
    
    End If
    
    MsgBox "Done!已得到所有的子文件夹名称。"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

(2) 复制子文件夹，并删除旧的文件夹

Sub RenameFolder()

    '复制文件夹到新的路径，并删除旧的文件夹。
    
    Dim row_final As Integer, ii As Integer, old_name As String, new_name As String
    Dim tar_sheet As Worksheet, fso As Object, root_path As String
    
    Set tar_sheet = ThisWorkbook.Worksheets("1 复制文件夹")
    
    row_final = tar_sheet.Range("A65535").End(xlUp).Row
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    root_path = tar_sheet.Range("B1").Value2
    
    If row_final > 3 Then
    
        For ii = 4 To row_final
        
            old_name = root_path & "\" & tar_sheet.Cells(ii, 1).Value2
            
            new_name = root_path & "\" & tar_sheet.Cells(ii, 2).Value2
            
            If Not isDirectory(new_name) Then
            
                fso.CopyFolder old_name, new_name
                
            Else
                
                MsgBox "文件夹已存在：" & new_name
                
            End If
            
            '删除旧文件夹
            fso.DeleteFolder old_name
            
        Next ii
    
    End If
    
    MsgBox "Done!文件夹已重命名。"

    Exit Sub

End Sub

Function isDirectory(pathname As String) As Boolean

    '用于判断文件夹是否存在
    
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    isDirectory = fso.FolderExists(pathname)

End Function

2.2 批量修改文件的名称

（1）获取所有文件的路径

表2 修改文件名：

新建一个模块，插入如下代码：

Option Explicit

Option Base 1

Dim ArrName() As String, jj As Integer

Sub getFileName()

    '给定父文件夹名称，获取全部子文件的路径
    
    Dim folder As String, fso As Object, fld As Object, tar_sheet As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set tar_sheet = ThisWorkbook.Worksheets("2 修改文件名")
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    jj = 0
    
    folder = tar_sheet.Range("B1").Value2
    
    If fso.FolderExists(folder) Then
    
        Set fld = fso.getFolder(folder)
        
        LookUpAllFiles fld
    
    Else
    
        MsgBox "父文件夹不存在，请检查！"
        
        Exit Sub
    
    End If
    
    If jj > 0 Then
    
        tar_sheet.Range("A4").Resize(jj, 1) = Application.Transpose(ArrName)
        
        Erase ArrName
    
    End If
    
    MsgBox "Done!已得到所有子文件的路径。"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Exit Sub

End Sub

Sub LookUpAllFiles(fld As Object)

    '遍历文件
    Dim file As Object, outFld As Object
    
    For Each file In fld.Files
    
        jj = jj + 1
                
        ReDim Preserve ArrName(1 To jj)
                
        ArrName(jj) = fld.Path & "\" & file.Name

    Next
    
    For Each outFld In fld.subFolders
    
        LookUpAllFiles outFld    '递归法，调用自身
    
    Next
    
End Sub

因为 Name 无法创建文件夹，所以在2.1节中，先复制子文件夹，为后续Name语句的使用做准备。

（2）批量修改文件名称

Sub RenameFiles()

    '重命名文件
    
    Dim kk As Integer, row_Namefinal As Integer, tar_sheet As Worksheet
    
    Dim arr_Name() As String, old_name As String, new_name As String
    
    Set tar_sheet = ThisWorkbook.Worksheets("2 修改文件名")
    
    row_Namefinal = tar_sheet.Range("A65535").End(xlUp).Row
    
    ReDim arr_Name(1 To row_Namefinal, 1 To 2)
    
    '临时存储文件名称
    With tar_sheet
        
        For kk = 4 To row_Namefinal
        
            arr_Name(kk, 1) = .Cells(kk, 1).Value2
            arr_Name(kk, 2) = .Cells(kk, 2).Value2
            
        Next kk
        
    End With
    
    '文件重命名
    If row_Namefinal > 3 Then
    
        For kk = 4 To row_Namefinal
        
            old_name = arr_Name(kk, 1)
            
            new_name = arr_Name(kk, 2)
            
            Name old_name As new_name
        
        Next kk
    
    End If
    
MsgBox "Done！已完成所有文件重命名！"

    Exit Sub
    
End Sub