Rename File Folders

Firstly thank you for taking the time to read. Using the following formula folders were automatically created in windows explorer:

Code:

---

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

---

Unfortunately when this was first run it created the folders with employee surname first then employee number e.g. SMITH 01234567. There are numerous files in each folder of which there are over 500 folders. Is there an easy way to rename these folders so the employee number comes first e.g. 01234567 SMITH?

This should work. Check the output in the debug first, before uncommenting Name line

Code:

---

Sub Test()
    pth = "F:\"    'Change to suit
    Dim fso, f
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(pth)
    For Each f In fld.subfolders
        x = Split(f.Name)
        If UBound(x) = 1 Then
            If IsNumeric(x(1)) Then
                OldFolderName = pth & f.Name
                NewFolderName = pth & x(1) & " " & x(0)
                Debug.Print NewFolderName
                'Name OldFolderName As NewFolderName
            End If
        End If
    Next
End Sub

---