Переместить файлы после изменения их имен, как?

Question

Я изменил код таким образом, чтобы он переименовал мои имена файлов, основанные на столбце. Тем не менее, есть цикл, и программа меняет имя того же файла, пока не получится ошибка. Как изменить имя, переместить файл в другую папку и затем обработать следующий файл? Ниже приведен код и важная часть отделена от «--------------

Спасибо!

Option Explicit 

Sub ListFiles() 

'http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html 

Application.ScreenUpdating = False 

'Set a reference to Microsoft Scripting Runtime by using 
'Tools > References in the Visual Basic Editor (Alt+F11) 

'Declare the variables 
Dim objFSO As Scripting.FileSystemObject 
Dim objTopFolder As Scripting.Folder 
Dim strTopFolderName As String 

'Insert the headers for Columns A through F 
Range("A1").Value = "File Name" 
Range("B1").Value = "File Size" 
Range("C1").Value = "File Type" 
Range("D1").Value = "Date Created" 
Range("E1").Value = "Date Last Accessed" 
Range("F1").Value = "Date Last Modified" 
Range("G1").Value = "Parent Folder" 
Range("H1").Value = "Short Path" 
Range("K1").Value = "New Name" 

'Assign the top folder to a variable 
strTopFolderName = "D:\" 

'Create an instance of the FileSystemObject 
Set objFSO = CreateObject("Scripting.FileSystemObject") 

'Get the top folder 
Set objTopFolder = objFSO.GetFolder(strTopFolderName) 

'Call the RecursiveFolder routine 
Call RecursiveFolder(objTopFolder, True) 

'Change the width of the columns to achieve the best fit 
Columns.AutoFit 


End Sub 

Sub RecursiveFolder(objFolder As Scripting.Folder, _ 
IncludeSubFolders As Boolean) 


'Declare the variables 
Dim objFile As Scripting.File 
Dim objSubFolder As Scripting.Folder 
Dim NextRow As Long 
Dim Sample As String 

'Find the next available row 
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1 

'Loop through each file in the folder 
For Each objFile In objFolder.Files 
    Cells(NextRow, "A").Value = objFile.Name 
    Cells(NextRow, "B").Value = objFile.Size 
    Cells(NextRow, "C").Value = objFile.Type 
    Cells(NextRow, "D").Value = objFile.DateCreated 
    Cells(NextRow, "E").Value = objFile.DateLastAccessed 
    Cells(NextRow, "F").Value = objFile.DateLastModified 
    Cells(NextRow, "G").Value = objFile.ParentFolder 
    Cells(NextRow, "H").Value = objFile.ShortPath 

    '----------------------------- 
    'Comandos para copiar e colar as fórmulas que definirão o novo nome do arquivo 
     Range("I1").Copy 
      Range("I" & NextRow).PasteSpecial (xlPasteFormulas) 
      Range("I" & NextRow).Calculate 
       Range("J1").Copy 
        Range("J" & NextRow).PasteSpecial (xlPasteFormulas) 
        Range("J" & NextRow).Calculate 

    Sample = Range("J" & NextRow).Value 'Nome da amostra 

     objFile.Name = Sample & objFile.Name 'Mudança do nome do arquivo para incluir o nome da amostra 

      Cells(NextRow, "K").Value = objFile.Name 'Inserção do novo nome do arquivo após alteração 

    '---------------------------- 
    NextRow = NextRow + 1 

Next objFile 

'Loop through files in the subfolders 
If IncludeSubFolders Then 
    For Each objSubFolder In objFolder.SubFolders 
     Call RecursiveFolder(objSubFolder, True) 
    Next objSubFolder 
End If 

Application.ScreenUpdating = True 


End Sub 

Answer 1

Вы изменяете элементы петли изнутри, что (или обновляет) объект, элементы которого вы итерируете - в вашем случае - коллекция objFolder.Files.

Решение: в вашей петле собирайте старые, а также новые имена файлы в коллекции (массив или все, что вам нравится), вместо того чтобы переименовывать файлы напрямую. Затем повторите итерацию через новую коллекцию (вместо objFolder.Files) и выполните переименование.