Trying to loop through all Excel files

I am using a code which keeps the color and remove the conditional formatting. I have multiple files where i run this code for each file separately.

I am looking for a way that when i run the code it will popup the window for the selection of the folder. I will select the folder which contains multiple files then one by one code will run each file where it will keep the colors and remove the condition formatting then save and close the workbook.

I just tried to make these below code but really do not know how to develop further. Your help will be greatly appreciated.

Sub Format()
Dim ws As Worksheet
Dim mySel As Range, aCell As RangeSet ws = ThisWorkbook.Sheets("Data)
Set mySel = ws.UsedRange

For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
End With
Next aCell

mySel.FormatConditions.Delete

End Sub

And code to open the window.

Sub Folder()
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 haven't selected a folder!", vbExclamation
Exit Sub
End If
End With
Application.ScreenUpdating = False
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
End Sub
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(strFolder & strFile)
For I = 2 To wbk.Worksheets.Count

Try this - please test it on a copy of your folder first.

It will handle font name, font style, font color and fill color, but not fill effects, borders or number formatting. The code could be expanded for those.

Sub Folder()
    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 haven'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.FormatConditions.Count Then
                    xRg.Font.Name = xRg.DisplayFormat.Font.Name
                    xRg.Font.FontStyle = xRg.DisplayFormat.Font.FontStyle
                    xRg.Font.Color = xRg.DisplayFormat.Font.Color
                    If xRg.DisplayFormat.Interior.ColorIndex = xlColorIndexNone Then
                        xRg.Interior.ColorIndex = xlColorIndexNone
                    Else
                        xRg.Interior.Color = xRg.DisplayFormat.Interior.Color
                    End If
                End If
            Next xRg
            wsh.UsedRange.FormatConditions.Delete
        Next wsh
        strFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

5 Replies