VBA 批量变换文件名

1. 页面布局

在“main”Sheet中按照下面的格式编辑。

2. 实现代码

Private wsMain As Worksheet
Private intIdx As Long

Private Sub getExcelBookList(strPath As String)
    Dim fso As Object
    Dim objFile As Object
    Dim objFolder As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each objFolder In fso.GetFolder(strPath).SubFolders
        Call getExcelBookList(objFolder.Path)
    Next objFolder

    For Each objFile In fso.GetFolder(strPath).Files
        If Left(objFile.Name, 1) <> "~" Then
            wsMain.Cells(intIdx, 3) = strPath
            wsMain.Cells(intIdx, 4) = objFile.Name
            intIdx = intIdx + 1
        End If
    Next objFile
    
    Set objFile = Nothing
    Set objFolder = Nothing
    Set fso = Nothing
End Sub


Sub list()
    Set wsMain = ThisWorkbook.Sheets("main")
   
    intIdx = 6
    Do
        If wsMain.Cells(intIdx, 3) = "" Then
            Exit Do
        End If
        intIdx = intIdx + 1
    Loop

    Call getExcelBookList(wsMain.Cells(2, 3))
    
    Set wsMain = Nothing
End Sub



Sub prepare()
    Dim fso As Object
    Dim strExtentName As String
    Dim strBaseName As String
    Dim strPrefix As String
    Dim strSuffix As String
    Dim strFolderPath As String
    Dim strOldFileName As String
    Dim strNewFileName As String
        
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsMain = ThisWorkbook.Sheets("main")

    strPrefix = wsMain.Cells(3, 3)
    strSuffix = wsMain.Cells(4, 3)

    intIdx = 6
    While wsMain.Cells(intIdx, 3) <> ""
        
        If wsMain.Cells(intIdx, 2) = "" Then
            strFolderPath = wsMain.Cells(intIdx, 3)
            strOldFileName = wsMain.Cells(intIdx, 4)
            
            strBaseName = fso.GetBaseName(strFolderPath & "\" & strOldFileName)
            strExtentName = fso.GetExtensionName(strFolderPath & "\" & strOldFileName)
                        
            strNewFileName = strPrefix & strBaseName & strSuffix & IIf(strExtentName = "", "", "." & strExtentName)
            
            wsMain.Cells(intIdx, 5) = strNewFileName
                        
        End If
        
        intIdx = intIdx + 1
    Wend
        
    Set wsMain = Nothing
    Set fso = Nothing
End Sub

Sub exec()
    Dim fso As Object
    Dim objFile As Object
    Dim strFolderPath As String
    Dim strOldFileName As String
    Dim strNewFileName As String
        
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsMain = ThisWorkbook.Sheets("main")

    intIdx = 6
    While wsMain.Cells(intIdx, 3) <> ""
        
        If wsMain.Cells(intIdx, 2) = "" Then
            strFolderPath = wsMain.Cells(intIdx, 3)
            strOldFileName = wsMain.Cells(intIdx, 4)
            strNewFileName = wsMain.Cells(intIdx, 5)
                        
            If strOldFileName <> strNewFileName Then
                Set objFile = fso.GetFile(strFolderPath & "\" & strOldFileName)
                objFile.Name = strNewFileName
                Set objFile = Nothing
            End If
            
            wsMain.Cells(intIdx, 2) = "Done"
            
        End If
        
        intIdx = intIdx + 1
    Wend
    
    MsgBox "Done."
    
    Set wsMain = Nothing
    Set fso = Nothing
End Sub


Sub clear()
    Set wsMain = ThisWorkbook.Sheets("main")
    
    wsMain.Range("B6", "E" & Rows.Count).ClearContents
    
    Set wsMain = Nothing
End Sub