Loop through all font colored cells in a range - excel

Question

I extracted the data according to ciriteria and marked them as blue. I'm looking for help with a Macro which would loop through all font colored cells (Blue) in a range.
I want to use only font colored cells in a range and mark in different color. And Msgbox show data that meet the criteria.
I had trouble finding information on looping through cells which contain only a specified colour. Anyone know how this could be done?
Dim i As Long
Dim LastRow As Integer
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Msg = "Data:"
For i = 1 To LastRow
If Cells(i + 1, 2).Value - Cells(i, 2).Value <> 0 Then
Cells(i, 2).Font.Color = vbBlue
Cells(i, 1).Font.Color = vbBlue
For Each Cell In Range("A:B")
If Cells(i, 1).Font.Color = vbBlue And Cells(i + 1, 1).Value - Cells(i, 1).Value > 4 Then
Cells(i, 2).Font.Color = vbGreen
Cells(i, 1).Font.Color = vbGreen
End If
Next
Msg = Msg & Chr(10) & i & " ) " & Cells(i, 2).Value & " : " & " --> " & Cells(i, 1).Value
End If
Next i
MsgBox Msg, vbInformation

Answer 1

There are multiple issues with your code:
Your loops are nested. You are searching through all the data every time you prepare one line. ==> Move the inner loop behind the loop you're coloring in.
The result message Msg = Msg & Chr(10) & i is constructed outside of the If Cells(i, 1).Font.Color = vbBlue And... condition, meaning that every line will be written into the result String. Move this part inside the 2nd loop, and the string should be contain only blue lines.
Also, please don't loop through For Each Cell In Range("A:B"). This will examine every cell in those columns, way beyond those who contain actual data. Use LastRow as in the first loop.

Answer 2

I believe you should be able to use the Find function to do this....
For example, select some cells on a sheet then execute:
Application.FindFormat.Interior.ColorIndex = 1
This will colour the cells black
Now execute something like:
Debug.Print ActiveCell.Parent.Cells.Find(What:="*", SearchFormat:=True).Address
This should find those cells. So you should be able to define your required Font with the FindFormat function.
BTW, make sure to test to see if the range returned is nothing for the case where it cant find any matches..
Hope that helps.
Edit:
The reason I would use the find method is because your code checks each cell in two columns. The Find method should be much quicker.
You will need to have a Do - While loop to find all cells in a range which is common with the Find function in VBA.
If you run this function, it should debug the address of any font matches that you are looking for - for a particular sheet. This should give you the idea...
Sub FindCells()
Dim rData As Range, rPtr As Range
Set rData = ActiveSheet.Range("A:B")
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbBlue
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbGreen
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
End Sub
Ok then - sorry keep getting distracted..
This code will search for cells with your fonts for a particular data range.
I believe you just need to implement your logic into the code...
Option Explicit
Public Sub Test()
Dim rData As Range
Set rData = Sheet1.Range("A:B")
Call EnumerateFontColours(rData, vbBlue)
Call EnumerateFontColours(rData, vbGreen)
End Sub
Public Sub EnumerateFontColours(ByVal DataRange As Range, ByVal FontColour As Long)
Dim rPtr As Range
Dim sStartAddress As String
Dim bCompleted As Boolean
Application.FindFormat.Clear
Application.FindFormat.Font.Color = FontColour
Set rPtr = DataRange.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
sStartAddress = rPtr.Address
Do
'**********************
Call ProcessData(rPtr)
'**********************
Set rPtr = DataRange.Find(What:="*", After:=rPtr, SearchFormat:=True)
If Not rPtr Is Nothing Then
If rPtr.Address = sStartAddress Then bCompleted = True
Else
bCompleted = True
End If
Loop While bCompleted = False
End If
End Sub
Public Sub ProcessData(ByVal r As Range)
Debug.Print r.Address
End Sub