Removing Specific Fill Colors

[DivineKael]

Hi,

I would like to ask for any advice on how to make my VBA code run faster. What I'm doing is, I have a list of workbooks that I need to check if each worksheet inside it contains the target fill colors that I'm looking. If a target fill color is seen in the current worksheet, I remove the fill color.

I already set Application.ScreenUpdating to False and minimize the usage of .Select(), but it is still slow.

My code is something like this. This function is being called by another function, since I need to check each sheet in the current workbook



Public Function removeFillColors(ws as Worksheet)
Dim searchKey as Range
Dim cellRange as Range

' This looks at the sheet for a specific keyword
' If the keyword is found, proceed to the removing of fill colors
Set searchKey = GetSearchKey(ws)

If not searchKey Is Nothing Then

'Loop each cell in UsedRange

For each cellRange In ws.UsedRange



'If the cell's fill color exist in my dictionary of target fill colors
'Remove the fill color of the current cell

If dictColors.Exists(cellRange.Interior.Color) Then

cellRange.Interior.Color = xlNone

End If

next cellRange

End IF
End Function


If my list contains only one file, it takes about 16 seconds. But if I add another file, it really takes time that I'm forced to stop it. :(

Would really appreciate if someone can give me an advice on how to solve my problem.

[SamT]

A hint:

For each IC in (DictColors)
Application.FindFormat.Interior.Color = IC

Set Cel = UsedRange.Find(*, SearchFormat=True)
Do While Not Cel is Nothing
Cel.Interior.Color = xlNone
Set Cel = FindNext(Cel)
Loop
Next IC

[DivineKael]

I have tried updating my code to the hint you gave me. I tried testing it first on 1 file but it seems it's skipping the cells that has no value(but has the target fill color to be removed).
I also noticed that it also taking too much time to reach the "Debug" statement (even until now). I'm not really used to VBA yet, so I'm not sure what part I'm having mistakes.



For each targetColorKey In dictColors.Keys
Application.FindFormat.Interior.Color = targetColorKey

Set cellRange = ws.UsedRange("*", SearchFormat:=True)
Do While Not cellRange Is Nothing
cellRange.Interior.Color = xlNone
hasChange = true
Set cellRange = ws.UsedRange.FindNext(cellRange)
Loop
Next targetColorKey

Debug.Print "Procees has reached here..."

[SamT]

Set cellRange = ws.UsedRange.Find("*", SearchFormat:=True) 'Note "Find"
Do While Not cellRange Is Nothing
cellRange.Interior.Color = xlNone
hasChange = true
Set cellRange = FindNext(cellRange) 'Note lack of Range
Loop

I would use


'Place at top of Procedure
Dim X
Dim SearchRange As Range
'End Placement

Set SearchRange = Nothing 'Start Fresh with next ws.
X = Timer
Set SearchRange = ws.UsedRange

For each targetColorKey In dictColors.Keys
Application.FindFormat.Interior.Color = targetColorKey

Set cellRange = SearchRange.Find("*", SearchFormat:=True) 'Note SearchRange include ws and UsedRange
Do While Not cellRange Is Nothing
cellRange.Interior.Color = xlNone
hasChange = true
Set cellRange = FindNext(cellRange)
Loop
Set CellRange = Nothing 'Start Fresh with next Color
Next targetColorKey

Debug.Print "Process took " & Timer - X & " Seconds."

'Next ws 'Not used at this time

Note that I would only time the While loop, pausing before each ColorKey. I would also add one ColorKey that did NOT exist on the sheet, just to have a baseline. If you have several thousand Cells, the baseline could be large. If all the colored Cells are in a few columns, shrink SearchRange to only those columns. It is quite possible that UsedRange is much larger than it appears.

Run This Code before working on any ws. VBA Express : Excel - Reduce Excel File Size (http://www.vbaexpress.com/kb/getarticle.php?kb_id=83). It will set UsedRange accurately.

[DivineKael]

Question on the part below, is it supposed to be like this? Because I'm having compilation error.
Assuming that it should be SearchRange.FindNext, I just noticed when it enters the while statement it will remove all fill colors regardless if its the "target fill color".
It seems like if it found a cell with the target fill color, starting from that cell, it will check each individual cell and removed the fill color. :dunno



Public Function removeFillColors(ws Worksheet)
call ExcelDiet(ws) <---- I added the code you referred me
....
Do While Not cellRange Is Nothing
cellRange.Interior.Color = xlNone
hasChange = true
Set cellRange = FindNext(cellRange) <---- This should be like SearchRange.FindNext(cellRange) right?
Loop
End Function

[SamT]

Well... I learned something: It appears that you can't use FindFormat with FindNext. So... new Code

Replace from "For Each" to "Next targetColorKey".
Note "Record hasChange here".

hasChange = False 'Start Fresh with each ws

For Each targetColorKey In dictColors.Keys
Application.FindFormat.Interior.Color = targetColorKey

Set CellRange = SearchRange.Find(What:="*", After:=SearchRange.Cells(SearchRange.Cells.Count), SearchFormat:=True) 'Start searching at TopLeft (After the BottomRight cell)
If Not CellRange Is Nothing Then
Do
CellRange.Interior.Color = xlNone
hasChange = True
Set CellRange = SearchRange.Find(What:="*", After:=CellRange, SearchFormat:=True)
Loop While Not CellRange Is Nothing
End If
Set CellRange = Nothing 'Start Fresh with next Color
Next targetColorKey

'Record hasChange here '<---------------


Let me know how it goes. S'il vous plaît.

[DivineKael]

I tried executing base on the changes above but when I look at the output the cells that doesn't have text value(but has fill color) were not removed. Sorry if I'm not clear with my problem.

For example if you look at the image below. The cells encircled with blue were correctly removed, but the fill color for those cells that doesn't have text value were not remove(Example, the one encircled with red). I wanted to remove the target fill colors in all sheets, regardless if they text or not.
28772

I cant really think of any other way other than traversing my ws.UsedRange and checking if it has the target color(which is taking a looong time)