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

CodePudding user response：

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

CodePudding user response：

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

CodePudding user response：

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