重命名目录中的文件不仅是文件夹

Question

我正在用 excel 处理一个项目，我正在重命名多个文件。

现在我正在使用此代码

Sub RenameFiles()  

Dim xDir As String  
Dim xFile As String  
Dim xRow As Long  
With Application.FileDialog(msoFileDialogFolderPicker)  
    .AllowMultiSelect = False  
If .Show = -1 Then  
    xDir = .SelectedItems(1)  
    xFile = Dir(xDir & Application.PathSeparator & "*")  
    Do Until xFile = ""  
        xRow = 0  
        On Error Resume Next  
        xRow = Application.Match(xFile, Range("A:A"), 0)  
        If xRow > 0 Then  
            Name xDir & Application.PathSeparator & xFile As _  
            xDir & Application.PathSeparator & Cells(xRow, "G").Value  
        End If  
        xFile = Dir  
    Loop  
End If  
End With    
End Sub    

这让我可以更改一个特定文件夹中文件的名称，但我希望能够选择包含子文件夹的主文件夹，它会更改与我在我的 excel 表中创建的名称相对应的所有名称。

Answer 1

我相信您知道重命名文件如果出错可能会产生非常严重的后果，有时甚至是灾难性的后果，话虽如此，我希望已采取所有必要措施来避免这些问题。

数据和代码：
A 和 G 列似乎包含文件的 "old" 和 "new" 名称（不包括路径），这就是询问的原因路径的用户以及为子文件夹运行文件重命名的可能性。

发布的代码将文件夹（以及预期的子文件夹）中的每个文件与数据中的文件列表进行比较，这可能很耗时。

另外，我建议跟踪哪些文件已被重命名，以便在出现任何错误时，可以轻松地追溯并撤消可能出现的错误。

提出的解决方案
下面提出的解决方案使用FileSystemObject object，它提供了对机器文件系统的强大访问，您可以通过两种方式与之交互：Early and Late Binding (Visual Basic)。这些程序使用后期绑定，要使用早期绑定见How do I use FileSystemObject in VBA?

1. Folders_ƒGet_From_User：要求用户选择文件夹并处理或不处理子文件夹的函数。它返回所选子文件夹的列表（仅名称），不包括没有文件的文件夹。
2. Files_Get_Array：使用所有要处理的文件名创建和排列（旧的和新的）
3. Files_ƒRename：此函数重命名从第 1 点获得的列表中的任何文件夹中找到的所有文件。这些过程不是根据列表验证子文件夹中存在的每个文件，而是检查列表中的文件Exist 在任何文件夹中，如果是，则传递给执行重命名并返回结果的函数 File_ƒRename_Apply，从而允许创建“Audit Track”数组。它返回一个数组，其中包含所有文件夹列表中列表中所有文件名的结果（从第 1 点和第 2 点开始）。
4. File_Rename_Post_Records：创建一个名为 FileRename(Track) 的工作表（如果不存在）以发布 Files_ƒRename 函数结果的 Audit Track。

它们都是从过程中调用的：Files_Rename

如果您对所使用的资源有任何疑问，请告诉我。

Option Explicit

Private Const mk_Wsh As String = "FileRename(Track)"
Private Const mk_MsgTtl As String = "Files Rename"
Private mo_Fso As Object

…

Sub Files_Rename()
    Dim aFolders() As String, aFiles As Variant
    Dim aRenamed As Variant

    
    Set mo_Fso = CreateObject("Scripting.FileSystemObject")
    
    If Not (Folders_ƒGet_From_User(aFolders)) Then Exit Sub
                    
    Call Files_Get_Array(aFiles)
                    
    If Not (Files_ƒRename(aRenamed, aFolders, aFiles)) Then
        Call MsgBox("None file was renamed", vbInformation, mk_MsgTtl)
        Exit Sub
    End If
   
    Call File_Rename_Post_Records(aFiles, aRenamed)
    Call MsgBox("Files were renamed" & String(2, vbLf) _
        & vbTab & "see details in sheet [" & mk_Wsh & "]", vbInformation, mk_MsgTtl)
                   
    End Sub

…

Private Function Folders_ƒGet_From_User(aFolders As Variant) As Boolean
Dim aFdrs As Variant
Dim oFdr As Object, sFolder As String, blSubFdrs As Boolean
    
    Erase aFolders
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Function
        sFolder = .SelectedItems(1)
    End With
    
    If MsgBox("Do you want to include subfolders?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
            mk_MsgTtl) = vbYes Then blSubFdrs = True

    Set oFdr = mo_Fso.GetFolder(sFolder)
    
    Select Case blSubFdrs
    
    Case False
        
        If oFdr.Files.Count > 0 Then
            aFdrs = aFdrs & "|" & oFdr.Path
        
        Else
            MsgBox "No files found in folder:" & String(2, vbLf) & _
                        vbTab & sFolder & String(2, vbLf) & _
                            vbTab & "Process is being terminated.", _
                                vbInformation, mk_MsgTtl
            Exit Function
        
        End If
        
    Case Else
        
        Call SubFolders_Get_Array(aFdrs, oFdr)

        If aFdrs = vbNullString Then
            MsgBox "No files found in folder & subfolders:" & String(2, vbLf) & _
                        vbTab & sFolder & String(2, vbLf) & _
                            vbTab & "Process is being terminated.", _
                                vbInformation, mk_MsgTtl
            Exit Function
    
        End If
        
    End Select
    
    Rem String To Array
    aFdrs = Mid(aFdrs, 2)
    aFdrs = Split(aFdrs, "|")
    aFolders = aFdrs
    
    Folders_ƒGet_From_User = True
    
    End Function

…

Private Sub SubFolders_Get_Array(aFdrs As Variant, oFdr As Object)
Dim oSfd As Object
    
    With oFdr
        If .Files.Count > 0 Then aFdrs = aFdrs & "|" & .Path
        For Each oSfd In .SubFolders
            Call SubFolders_Get_Array(aFdrs, oSfd)
    Next: End With
    
    End Sub

…

Private Sub Files_Get_Array(aFiles As Variant)
Dim lRow As Long
    
    With ThisWorkbook.Sheets("DATA")  'change as required
        lRow = .Rows.Count
        If Len(.Cells(lRow, 1).Value) = 0 Then lRow = .Cells(lRow, 1).End(xlUp).Row
        aFiles = .Cells(2, 1).Resize(-1 + lRow, 7).Value
    End With

    End Sub

…

Private Function Files_ƒRename(aRenamed As Variant, aFolders As Variant, aFiles As Variant) As Boolean
Dim vRcd As Variant:    vRcd = Array("Filename.Old", "Filename.New")
Dim blRenamed As Boolean
Dim oDtn As Object, aRcd() As String, lRow As Long, bFdr As Byte
Dim sNameOld As String, sNameNew As String
Dim sFilename As String, sResult As String
    
    aRenamed = vbNullString
    
    Set oDtn = CreateObject("Scripting.Dictionary")
    vRcd = Join(vRcd, "|") & "|" & Join(aFolders, "|")
    vRcd = Split(vRcd, "|")
    oDtn.Add 0, vRcd
                    
    With mo_Fso
        
        For lRow = 1 To UBound(aFiles)

            sNameOld = aFiles(lRow, 1)
            sNameNew = aFiles(lRow, 7)
            vRcd = sNameOld & "|" & sNameNew
            
            For bFdr = 0 To UBound(aFolders)
            
                sResult = Chr(39)
                sFilename = .BuildPath(aFolders(bFdr), sNameOld)
                            
                If .FileExists(sFilename) Then
    
                    If File_ƒRename_Apply(sResult, sNameNew, sFilename) Then blRenamed = True
            
                End If
            
                vRcd = vRcd & "|" & sResult
            
            Next
           
            vRcd = Mid(vRcd, 2)
            vRcd = Split(vRcd, "|")
            oDtn.Add lRow, vRcd
    
    Next: End With
    
    If Not (blRenamed) Then Exit Function
    
    aRenamed = oDtn.Items
    aRenamed = WorksheetFunction.Index(aRenamed, 0, 0)
    Files_ƒRename = True
    
    End Function

…

Private Function File_ƒRename_Apply(sResult As String, sNameNew As String, sFileOld As String) As Boolean
    
    With mo_Fso.GetFile(sFileOld)
        
        sResult = .ParentFolder
        On Error Resume Next
        .Name = sNameNew
        If Err.Number <> 0 Then
            sResult = "¡Err: " & Err.Number & " - " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
    
    End With
            
    File_ƒRename_Apply = True
    
    End Function

…

Private Sub File_Rename_Post_Records(aFiles As Variant, aRenamed As Variant)
Const kLob As String = "lo.Audit"
Dim blWshNew As Boolean
Dim Wsh As Worksheet, Lob As ListObject, lRow As Long
    
    Rem Worksheet Set\Add
    With ThisWorkbook
        
        On Error Resume Next
        Set Wsh = .Sheets(mk_Wsh)
        On Error GoTo 0
        
        If Wsh Is Nothing Then
            
            .Worksheets.Add After:=.Sheets(.Sheets.Count)
            Set Wsh = .Sheets(.Sheets.Count)
            blWshNew = True
        
    End If: End With
        
    Rem Set ListObject
    With Wsh
        
        .Name = mk_Wsh
        .Activate
        Application.GoTo .Cells(1), 1
        
        Select Case blWshNew
        
        Case False
            
            Set Lob = .ListObjects(kLob)
            lRow = 1 + Lob.ListRows.Count

        Case Else

            With .Cells(2, 2).Resize(1, 4)
                .Value = Array("TimeStamp", "Filename.Old", "Filename.New", "Folder.01")
                Set Lob = .Worksheet.ListObjects.Add(xlSrcRange, .Resize(2), , xlYes)
                Lob.Name = "lo.Audit"
                lRow = 1
            
    End With: End Select: End With
        
    Rem Post Data
    With Lob.DataBodyRange.Cells(lRow, 1).Resize(UBound(aRenamed), 1)
        .Value = Format(Now, "YYYYMMDD_HHMMSS")
        .Offset(0, 1).Resize(, UBound(aRenamed, 2)).Value = aRenamed
        .CurrentRegion.Columns.AutoFit
    End With
    
    End Sub

Answer 2

重命名文件（子文件夹）

• 几乎没有经过足够的测试。
• 您最好在应该运行它的文件夹中创建一个副本，以避免丢失文件。
• 它将文件夹及其子文件夹中的所有文件写入字典对象，其键（文件路径）将根据列A 中的文件路径进行检查。如果匹配，文件将重命名为 G 列中的名称，文件路径相同。
• 在重命名之前，它仅根据字典中的文件路径检查每个新文件路径。
• 如果文件名无效，它将失败。
• 将完整代码复制到标准模块，例如Module1。
• 调整第一个过程的常量部分中的值。
• 只运行第一个过程，其余的由它调用。

守则

Option Explicit

Sub renameFiles()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Dim Cols As Variant
    Cols = Array("A", "G")
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define worksheet.
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    ' Define Lookup Column Range.
    Dim rng As Range
    Set rng = defineColumnRange(ws, Cols(LBound(Cols)), FirstRow)
    ' Write values from Column Ranges to jagged Column Ranges Array.
    Dim ColumnRanges As Variant
    ColumnRanges = getColumnRanges(rng, Cols)
    
    ' Pick a folder.
    Dim FolderPath As String
    FolderPath = pickFolder
    
    ' Define a Dictionary object.
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    ' Write the paths and the names of the files in the folder
    ' and its subfolders to the Dictionary.
    Set dict = getFilesDictionary(FolderPath)
    
    ' Rename files.
    Dim RenamesCount As Long
    RenamesCount = renameColRngDict(ColumnRanges, dict)

    ' Inform user.
    If RenamesCount > 0 Then
        MsgBox "Renamed " & RenamesCount & " file(s).", vbInformation, "Success"
    Else
        MsgBox "No files renamed.", vbExclamation, "No Renames"
    End If
    
End Sub

Function defineColumnRange(Sheet As Worksheet, _
                           ColumnIndex As Variant, _
                           FirstRowNumber As Long) _
  As Range
    Dim rng As Range
    Set rng = Sheet.Cells(FirstRowNumber, ColumnIndex) _
                   .Resize(Sheet.Rows.Count - FirstRowNumber + 1)
    Dim cel As Range
    Set cel = rng.Find(What:="*", _
                       LookIn:=xlFormulas, _
                       SearchDirection:=xlPrevious)
    If Not cel Is Nothing Then
        Set defineColumnRange = rng.Resize(cel.Row - FirstRowNumber + 1)
    End If
End Function

Function getColumnRanges(ColumnRange As Range, _
                         BuildColumns As Variant) _
  As Variant
    Dim Data As Variant
    ReDim Data(LBound(BuildColumns) To UBound(BuildColumns))
    Dim j As Long
    With ColumnRange.Columns(1)
        For j = LBound(BuildColumns) To UBound(BuildColumns)
            If .Rows.Count > 1 Then
                Data(j) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
                  .Column - .Column).Value
            Else
                Dim OneCell As Variant
                ReDim OneCell(1 To 1, 1 To 1)
                Data(j) = OneCell
                Data(1, 1) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
                  .Column - .Column).Value
            End If
        Next j
    End With
    getColumnRanges = Data
End Function

Function pickFolder() _
  As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            pickFolder = .SelectedItems(1)
        End If
    End With
End Function

' This cannot run without the 'listFiles' procedure.
Function getFilesDictionary(ByVal FolderPath As String) _
  As Object
    Dim dict As Object ' ByRef
    Set dict = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.FileSystemObject")
        listFiles dict, .GetFolder(FolderPath)
    End With
    Set getFilesDictionary = dict
End Function

' This is being called only by 'getFileDictionary'
Sub listFiles(ByRef Dictionary As Object, _
              fsoFolder As Object)
    Dim fsoSubFolder As Object
    Dim fsoFile As Object
    For Each fsoFile In fsoFolder.Files
        Dictionary(fsoFile.Path) = Empty 'fsoFile.Name
    Next fsoFile
    For Each fsoSubFolder In fsoFolder.SubFolders
        listFiles Dictionary, fsoSubFolder
    Next
End Sub

' Breaking the rules:
' A Sub written as a function to return the number of renamed files.
Function renameColRngDict(ColumnRanges As Variant, _
                          Dictionary As Object) _
  As Long
    Dim Key As Variant
    Dim CurrentIndex As Variant
    Dim NewFilePath As String
    For Each Key In Dictionary.Keys
        Debug.Print Key
        CurrentIndex = Application.Match(Key, _
          ColumnRanges(LBound(ColumnRanges)), 0)
        If Not IsError(CurrentIndex) Then
            NewFilePath = Left(Key, InStrRev(Key, Application.PathSeparator)) _
              & ColumnRanges(UBound(ColumnRanges))(CurrentIndex, 1)
            If IsError(Application.Match(NewFilePath, Dictionary.Keys, 0)) Then
                renameColRngDict = renameColRngDict + 1
                Name Key As NewFilePath
            End If
        End If
    Next Key
End Function