Rename files in multiple folders and copy to new folder

[cmunoziii]

For the last year I have been downloading cash register X1 and Z1 files onto an SD card. Each night's files (X1 & Z1) are stored in a new folder with the naming convention "RP + [DATE]", (EX: RP120910, [YYMMDD]). I have 265 folders!!!<br><br>
I need to go through each folder, select the Z1 file (I don't care about the X1, X2 or Z2 files) and rename each with the following naming convention: "Z1 + folder_name + .xls". For Example: Folder RP120910 contains the Z1 file named "Z1_T1729.ECR". After renaming, the file should be "Z1RP120910.xls".<br><br>
As the VBA code loops through each subfolder, selecting and renaming the Z1 files, I would like the new files to be placed into a new folder named "Z1Files".<br><br>
Note: All subfolders are currently in a directory named "RegisterFiles". I am using Excel 2010.<br><br>
Can someone please save me from having to manually go through each file and rename it. I would greatly appreciate any help.

 

[patel45]

maybe you can arrange this code for your goal

Sub RenAllFilesInclSubFold()
    Dim fso As Object, fold As Object, fFile As Object
    Dim fPath As String, fName As String, oldName As String, newName As String
    fPath = "C:\test" ' ----- initial folder
    s = "_New"
'   ren files in parent folder
    fName = Dir(fPath & "\" & "*.xl*", vbNormal)
    Do While fName <> ""
        oldName = Left(fName, InStrRev(fName, ".") - 1)
        newName = Replace(fName, oldName, oldName & s)
       Name fPath & "\" & fName As fPath & "\" & newName
'        MsgBox "Name " & fPath & "\" & fName & " As " & fPath & "\" & newName
        fName = Dir
    Loop
'   ren files in subfolders
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fold = fso.GetFolder(fPath)
    For Each fFile In fold.subfolders
        fName = Dir(fFile.Path & "\*.xl*", vbNormal)
        Do While fName <> ""
            oldName = Left(fName, InStrRev(fName, ".") - 1)
            newName = Replace(fName, oldName, oldName & s)
            Name fFile.Path & "\" & fName As fFile.Path & "\" & newName
'            MsgBox "Name " & fPath & "\" & fName & " As " & fFilePath & "\" & newName
            fName = Dir
        Loop
    Next
'   ren subfolders
    fName = Dir(fPath & "\", vbDirectory)
    Do While fName <> ""
       If Left(fName, 1) <> "." Then
         newName = fName & s
         Name fPath & "\" & fName As fPath & "\" & newName
       End If
       fName = Dir
    Loop

End Sub

 

[cmunoziii]

Thanks Patel45! The code you pasted has certainly been a steer in the right direction. I'm going to continue working on it and then I will paste the code for everyone's use.

 

[cmunoziii]

Thanks again for posting the code that you did Patel45. I was able to use it and come up with my solution. Here is the code for anyone that might need to do something similar:

Sub RenAllFilesInclSubFold()

Dim fso As Object, fold As Object, fFile As Object
Dim fPath As String, fName As String, newName As String

fPath = "C:\mainFolder" ' ----- initial folder that contains all the subfolders
cnt = ""

'ren files in subfolders
Set fso = CreateObject("Scripting.FileSystemObject")
Set fold = fso.GetFolder(fPath)


For Each fFile In fold.subfolders
cnt = ""

'the files i want to rename and move, start with "Z1"
fName = Dir(fFile.Path & "\Z1*", vbNormal)

Do While fName <> ""
newName = "\myNewFileName & ".xls" 'or any ext you want
Name fFile.Path & "\" & fName As fFile.Path & newName
fso.MoveFile Source:=fFile.Path & newName, Destination:="C:\newFolder" 'this code will not create the new folder
fName = Dir
cnt = cnt & "i" 'just in case i have more than 1 Z1 file in a folder
Loop
Next
End Sub