Copy and creating a Folder for a certain file

Hello, quick praise and then my question.

Below is code I got help on that works great. It allowed me to change over

10,000 folder names from what they were to what they uniquely needed to be.

AlphaFrog helped me and I wanted to say thanks again.

Sub ChangeFolders()
    Dim curfolder As String
    Dim mypath As String
    Dim dirLook As String

    curfolder = "C:\Users\Joe\Desktop\Test\"
    dirLook = Dir(curfolder, vbDirectory)
    Do While dirLook <> vbNullString

        mypath = dirLook

        Call Rename_Folders

        dirLook = Dir

    Loop
    
End Sub

Sub Rename_Folders()
    Dim cell As Range
    For Each cell In Range("A1", Range("A" & Rows.Count).End(xlUp))
        Name cell.Value As cell.Offset(, 1).Value
    Next cell
End Sub

My next task is more complicated:

I have to search each folder and copy anywhere from zero (if the file is

not in that folder) to 10 or more unique files. The copied files need to be

put in a folder using mkdir that has the same name as the folder they where

found in.

My first step is to create a master directory for all the subfolders to be

placed in.

What I am wondering is: using the above code how do I change the

    curfolder = "C:\Users\Joe\Desktop\Test\"
    dirLook = Dir(curfolder, vbDirectory)
    Do While dirLook <> vbNullString

to also loop thru the subfolders.

Any help would be great.

Thanks
Joe

This will cycle through all sub folders and files in the directory assigned to fldrStart. If you want to go as deep as you can you would need to make this a function that calls itself until it runs out of folders.

Dim fldrStart as String
fldrStart = "Starting Folder Path"
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = fldrStart

Dim FSO As New FileSystemObject
Dim fldrName As Folder
Dim fldrSub As Folder
Set fldrName = FSO.GetFolder(fldrStart)
For Each fldrSub In fldrName.SubFolders

'CODE FOR FOLDERS HERE

Next fldrSub
Set fldrName = Nothing

Dim fileName
fileName = Dir(fldrStart, 7)
Do While fileName <> ""

'CODE FOR FILES HERE

Loop

Thanks for the response GaidenFocus:

Your code is Object which is even more difficult for me to understand.

I did find this code that I think I can modify to work for looping thru the files in the subfolders.

Sub OpenFolders()

    Dim IsFolder        As Boolean
    Dim ParentFolder    As String
    Dim SubFolder       As String
    
    
        ParentFolder = "C:\Users\Owner\Documents\"
        
        SubFolder = Dir(ParentFolder, vbDirectory)
        
            Do While SubFolder <> ""
                IsFolder = (GetAttr(ParentFolder & SubFolder) And vbDirectory) = vbDirectory
                    If IsFolder Then
                      ' Open this folder and open all Workbooks of type ".xlsm"
                        Call OpenFiles(ParentFolder & SubFolder)
                    End If
                SubFolder = Dir
            Loop
            
End Sub

Sub OpenFiles(ByVal FolderPath As String)

    Dim FileName As String
    Dim FileType As String
    
    
        FileType = ".xlsm"
        
        FileName = Dir(FolderPath & "\*." & FileType)
        
            Do While FileName <> ""
                'Workbooks.Open FileName
                'Modify Data
                'ActiveWorkbook.Close SaveChanges:=True
                FileName = Dir
            Loop
            
End Sub

I need to keep working on it but for now I think the subfolders will loop thru using the above code.

Thanks again

Joe