Forum Discussion
ShazSh
Feb 19, 2021Brass Contributor
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 cod...
- Feb 19, 2021
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
HansVogelaar
Feb 19, 2021MVP
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- ShazShMar 01, 2021Brass ContributorHansVogelaar Sir there is one more problem that code should save and close all the files. Currently all workbooks are open when code complete the processing. Please look into this problem if it does not bother. Thanks.
- HansVogelaarMar 01, 2021MVP
- ShazShMar 01, 2021Brass ContributorThank you very much
- ShazShFeb 22, 2021Brass ContributorThank you very much.