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

重命名文件（子文件夹）

• 没有足够的测试。
• 您最好在该文件夹中创建一个副本，以免丢失文件。
• 它将把文件夹及其子文件夹中的所有文件写入字典对象，该字典对象的键（文件路径）将根据column中的文件路径进行检查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