Loop through all font colored cells in a range

问题

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

回答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.

回答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

来源：https://stackoverflow.com/questions/34805347/loop-through-all-font-colored-cells-in-a-range

标签

excel

vba

loops

cells