时间戳

首页 > 解决方案 > 重命名目录中的文件不仅是文件夹

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

问题描述

我正在用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 表中创建的名称相对应的所有名称。

标签： excelvbafiledirectoryrename

解决方案

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

数据和代码：
似乎列A和G包含文件的“旧”和“新”名称（不包括路径），这就是向用户询问路径的原因以及运行文件重命名的可能性子文件夹也是如此。

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

此外，我会建议跟踪哪些文件已被重命名，因此如果出现任何错误，这允许轻松追溯并撤消可能出现的错误。

提出
的解决方案 下面提出的解决方案使用FileSystemObject 对象，该对象提供对机器文件系统的稳健访问，您可以通过两种方式与其交互：早期绑定和后期绑定 (Visual Basic)。这些程序使用后期绑定，要使用早期绑定，请参阅如何在 VBA 中使用 FileSystemObject？

  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)（如果不存在）的工作表来发布函数Audit Track的结果Files_ƒRename。

它们都是从过程中调用的：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

…</p> 

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

…</p> 

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

…</p> 

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

…</p> 

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

…</p> 

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

…</p> 

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

…</p> 

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

推荐阅读