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

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

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

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

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