replace file names characters "_" with " " in folders and multiple subfolders with more subfolders

[sachs_v5]

Hello All,

I'm new in the forum and after exploring the multiple (great) threads in the forum i have managed to create VBA code to:

- list all files in folder, subfolder and more subfolders using FSO function and loop calls of the same to get all files captured from path in designated Range;

Now i am struggling to use FSO function to replace file name character underscores "_" with spaces " ".

I got it to work but solely to the files in initial folder of designated path in Range (B2 cell).

So i kindly solicit help from the experts around here.

PS: If you can include a Msgbox count to pop-up something close to "x files renamed" it would be great!

Cheers and thanks to the contributions.

Regards,

sachs_v5

 

[Swayzy]

If you can list files then you can rename them with the rename function as you go through the folders. Store the file name as a variable instead of in a range and use the replace function to alter the string then use rename old variable as new variable. Then you can count the name changes and use application status bar function to show the count.

Best would be if you post your current code so we can see what you have now.

 

[Kenneth Hobson]

Welcome to the forum!

Yes, posting code is best so we can add or modify more easily. Paste code between code tags. Click the # icon to insert tags.

VBA's Name can be used but you may want to check if file exists already prior to renaming. FSO could be used to rename and check for renamed file's existence as well.

Without those extra parts, this should be close. As always, test on a backup copy of your files and folders.

Sub Main()
  Dim a, i As Long, j As Long, fn$, p$, fso As Object
  
  a = aFFs("C:\Users\lenovo1\Dropbox\Excel\t\", , True)
  If Not IsArray(a) Then Exit Sub
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  For j = LBound(a) To UBound(a)
    p = fso.GetParentFolderName(a(j)) & "\"
    fn = fso.getfilename(a(j))
    If InStr(fn, " ") > 0 Then
      Name a(j) As p & Replace(fn, "_", " ")
      i = i + 1
    End If
  Next j
  
  Select Case i
    Case 0
      MsgBox "No files were replaced."
    Case 1
      MsgBox "One file was replaced."
    Case Else
     MsgBox "Files replaced: " & i
  End Select
  
  Set fso = Nothing
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

 

[sachs_v5]

Hi guys,

I will post code later as im on restricted network.

I took Kenneth code and got it to work once only. After first run i manually renamed the files adding _ again and on 2nd run no files are getting renamed.

Also when running code with path c:\xpto it throws error 75 path\file access error.

Files to be renamed are in multiple sub folders inside sub folders inside folders. There are no folders with sub folders and files.

Thanks.

 

[Kenneth Hobson]

I suspect that either that path does not exist or you did not add the trailing backslash character.

When testing, you can change 2 lines of code for replacements.

1. Replace "_" in filename with " ".

If InStr(fn, "_") > 0 Then
      Name a(j) As p & Replace(fn, "_", " ")

2. Replace " " in filename with "_".

If InStr(fn, " ") > 0 Then
      Name a(j) As p & Replace(fn, " ", "_")

I tweaked the routines a bit more to take care of a few exception cases. I did not add error checking for file in use or such. One could check Read Only file attribute which may or may not indicate that the file is open somewhere.

Sub Main()
  Dim a, i As Long, j As Long, fn$, p$, fso As Object
  
  'a = aFFs("C:\Users\lenovo1\Dropbox\Excel\t\", , True)
  a = aFFs("C:\Users\hobs0003\Dropbox\Excel\t", , True)
  If Not IsArray(a) Then Exit Sub
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  For j = LBound(a) To UBound(a)
    p = fso.GetParentFolderName(a(j)) & "\"
    fn = fso.getfilename(a(j))
    If InStr(fn, "_") > 0 Then
      Name a(j) As p & Replace(fn, "_", " ")
      i = i + 1
    End If
  Next j
  
  Select Case i
    Case 0
      MsgBox "No files were replaced."
    Case 1
      MsgBox "One file was replaced."
    Case Else
     MsgBox "Files replaced: " & i
  End Select
  
  Set fso = Nothing
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, p As String, a() As String, v As Variant
  Dim b() As Variant, i As Long, fso As Object
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = fso.GetParentFolderName(myDir) & "\"
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      'add the folder name
      a(i) = p & a(i)
    End If
  Next i
  
  Set fso = Nothing
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

 

[sachs_v5]

Hi,

Appreciated for the tuned code. Still im getting run time error 53 file not found in some occasions namely when 3 or 4 sub folders down files are present with and without underscores, both type of files can be found inside the folders.
When i debug i can locate the issue on "(a(j))
If InStr(fn, "_") > 0 Then
Name a(j) As p & Replace(fn, "_", " ")
Unsure where issue can be as it worked fine for some of the folders where all files and underscore on the filename.
Sorry for not sharing the full code yet.
Regards,

sachs_v5

 

[sachs_v5]

Hi,

I have isolated the root cause for Run time error 53 file not found. My Path can have up to 20 subfolders and files located in last of them. Code is failing when file is present on 4th subfolder or below (5th, 6th, etc).
If code review can support so many subfolders how to write it?
Thanks.

sachs_v5

 

[Kenneth Hobson]

I don't know what code review means. If one of the files is the macros file, obviously it would fail.

You can use debug.print to view the a(j) file in a run prior to Name.

I will look a little deeper later today.

 

[sachs_v5]

Hi Kenneth,

My macro file is not part of the files listed.
I should have said reviewed code, my bad. Thanks for the help.

sachs_v5

 

[Kenneth Hobson]

I added a few extra error checking parts as I explained in #3 .

Comment out and uncomment the two lines of code as explained in #5 .

Had this been just for Workbook files, I would have used the last routine to check if it was open.

Note that it puts the name of the file that was not renamed, due to the renamed file already existing, into the Immediate window after a run.

Sub Main()
  Dim a, i As Long, j As Long, fn$, fn2$, p$, fso As Object
  
  a = aFFs("C:\Users\lenovo1\Dropbox\Excel\t\", , True)
  'a = aFFs("C:\Users\hobs0003\Dropbox\Excel\t", , True)
  If Not IsArray(a) Then Exit Sub
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  For j = LBound(a) To UBound(a)
    p = fso.GetParentFolderName(a(j)) & "\"
    fn = fso.getfilename(a(j))
    
    If InStr(fn, "_") > 0 Then
      fn2 = p & Replace(fn, "_", " ")
    'If InStr(fn, " ") > 0 Then
      'fn2 = p & Replace(fn, " ", "_")
      
      If Not IsFileOpen(CStr(a(j))) And Not fso.fileexists(fn2) Then
        'Name a(j) As fn2
        fso.MoveFile a(j), fn2
        i = i + 1
        Else 'Boo boo...
        Debug.Print "Overwrite issue?", fn2
      End If
    End If
  Next j
  
  Select Case i
    Case 0
      MsgBox "No files were replaced."
    Case 1
      MsgBox "One file was replaced."
    Case Else
     MsgBox "Files replaced: " & i
  End Select
  
  Set fso = Nothing
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, p As String, a() As String, v As Variant
  Dim b() As Variant, i As Long, fso As Object
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = fso.GetParentFolderName(myDir) & "\"
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      'add the folder name
      a(i) = p & a(i)
    End If
  Next i
  
  Set fso = Nothing
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

Function IsFileOpen(FileName As String)
  Dim iFilenum As Long
  Dim iErr As Long
   
  On Error Resume Next
  iFilenum = FreeFile()
  Open FileName For Input Lock Read As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=iFilenum]#iFilenum[/URL] 
  Close iFilenum
  iErr = Err
  On Error GoTo 0
   
  Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
  End Select
End Function

Function IsWorkbookOpen(stName As String) As Boolean
  Dim Wkb As Workbook
  On Error Resume Next ' In Case it isn't Open
  Set Wkb = Workbooks(stName)
  If Not Wkb Is Nothing Then IsWorkbookOpen = True
  'Boolean Function assumed To be False unless Set To True
End Function