Code Does not Loop through All folder and Sub folders - excel

Question

I am trying to Loop through all files and sub folders but my code is just works for single folder.
I want to apply this code on all Folders and subfolder which have workbooks.
Any help will be appreciated.
Sub KeepColor()
Dim strFolder As String
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim I As Long
Dim xRg As Range
With Application.FileDialog(4)
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "You 't selected a folder!", vbExclamation
Exit Sub
End If
End With
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Application.ScreenUpdating = FALSE
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(strFolder & strFile)
For Each wsh In wbk.Worksheets
For Each xRg In wsh.UsedRange
If xRg.DisplayFormat.Interior.ColorIndex = xlColorIndexNone Then
xRg.Interior.ColorIndex = xlColorIndexNone
Else
xRg.Interior.Color = xRg.DisplayFormat.Interior.Color
End If
Next xRg
wsh.UsedRange.FormatConditions.Delete
Next wsh
wbk.Close SaveChanges:=True
strFile = Dir
Loop
Application.ScreenUpdating = TRUE
End Sub

Answer 1

Dir is much faster than FileSystemObject if you have a filename pattern, so here's a function which mixes both:
Sub Tester()
Dim col As Collection, t
t = Timer
Set col = GetMatches("C:\Tester", "*.xls*")
Debug.Print Timer - t, col.Count
End Sub
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
'this is faster...
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern)
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
'this is slower...
'For Each f In fldr.Files
' If UCase(f.Name) Like filePattern Then colFiles.Add f
'Next f
Loop
Set GetMatches = colFiles
End Function

Answer 2

Please, try the next code:
Sub KeepColor()
Dim strFolder As String, fso As Object, parentFolder As Object, folder As Object
With Application.FileDialog(4)
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "You didn't select a folder!", vbExclamation
Exit Sub
End If
End With
Set fso = CreateObject("scripting.filesystemobject")
Set parentFolder = fso.GetFolder(strFolder)
Application.ScreenUpdating = False
ProcessAllFiles parentFolder, "xls*"
For Each folder In parentFolder.SubFolders
ProcessAllFiles folder, "xls*"
Next
Application.ScreenUpdating = True
End Sub
Sub ProcessAllFiles(strFold As Object, fileExt As String)
Dim fso As Object, objFile As Object, xRg As Range, wbk As Workbook, wsh As Worksheet
Set fso = CreateObject("scripting.filesystemobject")
For Each objFile In strFold.files
If fso.GetExtensionName(objFile.Name) Like fileExt Then
Set wbk = Workbooks.Open(objFile.path)
For Each wsh In wbk.Worksheets
For Each xRg In wsh.UsedRange
If xRg.DisplayFormat.Interior.ColorIndex = xlColorIndexNone Then
xRg.Interior.ColorIndex = xlColorIndexNone
Else
xRg.Interior.color = xRg.DisplayFormat.Interior.color
End If
Next xRg
wsh.UsedRange.FormatConditions.Delete
Next wsh
wbk.Close SaveChanges:=True
End If
Next
End Sub

Answer 3

This is a recursion job.
I am using a generic function, that returns a collection of all files (could be changed to array as well) - either for the folder or for all subfolders.
You need to add a reference to "Microsoft Scripting runtime"
Option Explicit
Sub testFindAllFiles()
Dim strFolder As String: strFolder = "XXXX" 'adjust to your needs
Dim colFiles As Collection
Set colFiles = findAllFilesByExtension(strFolder, "xls*", True)
Dim strFile As Variant
For Each strFile In colFiles
Debug.Print strFile
'do what you need with the file
Next
End Sub
Public Function findAllFilesByExtension(ByVal targetFolder As String, ByVal extension As String, _
Optional fWithSubfolders As Boolean = True) As Collection
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim colFiles As Collection: Set colFiles = New Collection
findFilesByExtension targetFolder, colFiles, extension, fso, fWithSubfolders
Set findAllFilesByExtension = colFiles
End Function
Private Sub findFilesByExtension(ByVal targetFolder As String, ByRef colFiles As Collection, _
extension As String, fso As FileSystemObject, fWithSubfolders As Boolean)
Dim objFolder As Folder, objFile As File
Dim subFolders As Folders
Set objFolder = fso.GetFolder(targetFolder)
For Each objFile In objFolder.Files
If Not objFile.Name Like "~*" Then
If objFile.Name Like "*." & extension Then
colFiles.Add objFile.Path
End If
End If
Next
If fWithSubfolders = True Then
Set subFolders = objFolder.subFolders
For Each objFolder In subFolders
findFilesByExtension objFolder.Path, colFiles, extension, fso, fWithSubfolders
Next
End If
End Sub