Microsoft Excel - Macro to Identify cells containing 1 of Top 10 values in range, without sorting

Asked By Rowland Hamilton on 07-Feb-13 06:51 PM

Folks: I figured it out (Really wanted Top 12 but ws being general):

[CODE]Sub BoldRows()

Dim shtSummary As Worksheet
Dim rngSummary As Range
Dim rngCell As Range
Dim rngTop12 As Range

Set shtSummary = ThisWorkbook.Worksheets("Summary")
Set rngSummary = shtSummary.Range("M7:M50")

    Application.ScreenUpdating = False
   
    shtSummary.Activate
    shtSummary.AutoFilterMode = False

    rngSummary.AutoFilter Field:=1, Criteria1:="12", _
      Operator:=xlTop10Items
    Set rngTop12 = rngSummary.SpecialCells(xlCellTypeVisible)
   
    For Each rngCell In rngTop12
      Range("A" & rngCell.Row & ":L" & rngCell.Row, "N" & rngCell.Row & ":X" & rngCell.Row). _
        Interior.Color = 65535
    Next
  
    shtSummary.AutoFilterMode = False
    Application.ScreenUpdating = True
   
End Sub[CODE]

Original Question:
How do I identify if the cell contains one of the top 10 values in range M7:M50, without sorting. This way, I can avoid referencing conditional formatting in my Macro?

Otherwise, how do I reference the conditional formatting?

Conditional Formatting is highlighting only the cells with the top 10 values in the column but I want it to highlight the entire row. Can not easily identify the conditional coloring using vba. Couldn't understand how to activate C Pearson's Functions either.

I tried:
[CODE]

Sub BoldRows()
Dim rngSummary As Range
Dim rngCell As Range

Set rngSummary = ThisWorkbook.Worksheets("Summary").Range("M7:M50")
'Need highlight entire row from columns A to X
For Each rngCell In rngSummary
    If rngCell.FormatConditions.Count > 0 Then '(1).Interior.Color = 65535 Then
    Range("A" & rngCell.Row & ":L" & rngCell.Row, "N" & rngCell.Row & ":X" & rngCell.Row).Interior.Color = 65535
    End If
Next

End Sub

[/CODE] 
But it highlights every row since each cell in column M has the conditional format eventhough the conditions are not met. And of course when it was just refering to color, it can't see the conditional colors.

If I could do it with out the many functions C Pearson uses, I would like to.

But, how would I use Chip Pearsons functions below in a macro?:
[CODE]

Function ActiveCondition(Rng As Range) As Integer
Dim Ndx As Long
Dim FC As FormatCondition
Dim Temp As Variant
Dim Temp2 As Variant

If Rng.FormatConditions.Count = 0 Then
    ActiveCondition = 0
Else
    For Ndx = 1 To Rng.FormatConditions.Count
    Set FC = Rng.FormatConditions(Ndx)
    Select Case FC.Type
      Case xlCellValue
      Select Case FC.Operator
      Case xlBetween
        Temp = GetStrippedValue(FC.Formula1)
        Temp2 = GetStrippedValue(FC.Formula2)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
         CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
         ActiveCondition = Ndx
         Exit Function
       End If
       Else
        If Rng.Value >= Temp And _
       Rng.Value <= Temp2 Then
       ActiveCondition = Ndx
       Exit Function
        End If
       End If

      Case xlGreater
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
        ActiveCondition = Ndx
        Exit Function
       End If
        Else
       If Rng.Value > Temp Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If

      Case xlEqual
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
         ActiveCondition = Ndx
         Exit Function
       End If
        Else
       If Temp = Rng.Value Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If

      Case xlGreaterEqual
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
         ActiveCondition = Ndx
         Exit Function
       End If
        Else
       If Rng.Value >= Temp Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If

    
      Case xlLess
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
        If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
         ActiveCondition = Ndx
         Exit Function
        End If
        Else
        If Rng.Value < Temp Then
         ActiveCondition = Ndx
         Exit Function
        End If
        End If

      Case xlLessEqual
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
        ActiveCondition = Ndx
        Exit Function
       End If
        Else
       If Rng.Value <= Temp Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If

      Case xlNotEqual
        Temp = GetStrippedValue(FC.Formula1)
        If IsNumeric(Temp) Then
       If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
        ActiveCondition = Ndx
        Exit Function
       End If
        Else
       If Temp <> Rng.Value Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If

     Case xlNotBetween
        Temp = GetStrippedValue(FC.Formula1)
        Temp2 = GetStrippedValue(FC.Formula2)
        If IsNumeric(Temp) Then
       If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) And _
        (CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then
        ActiveCondition = Ndx
        Exit Function
       End If
        Else
       If Not Rng.Value <= Temp And _
        Rng.Value >= Temp2 Then
        ActiveCondition = Ndx
        Exit Function
       End If
        End If
    
     Case Else
        Debug.Print "UNKNOWN OPERATOR"
     End Select

    Case xlExpression
      If Application.Evaluate(FC.Formula1) Then
     ActiveCondition = Ndx
     Exit Function
      End If

    Case Else
      Debug.Print "UNKNOWN TYPE"
   End Select

    Next Ndx

End If

ActiveCondition = 0


End Function
 

'''''''''''''''''''''''''''''''''''''''

Function ColorIndexOfCF(Rng As Range, _
    Optional OfText As Boolean = False) As Integer

Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
    If OfText = True Then
   ColorIndexOfCF = Rng.Font.ColorIndex
    Else
   ColorIndexOfCF = Rng.Interior.ColorIndex
    End If
Else
    If OfText = True Then
   ColorIndexOfCF = Rng.FormatConditions(AC).Font.ColorIndex
    Else
   ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex
    End If
End If

End Function
 

'''''''''''''''''''''''''''''''''''''''

Function ColorOfCF(Rng As Range, Optional OfText As Boolean = False) As Long

Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
    If OfText = True Then
   ColorOfCF = Rng.Font.Color
    Else
   ColorOfCF = Rng.Interior.Color
    End If
Else
    If OfText = True Then
   ColorOfCF = Rng.FormatConditions(AC).Font.Color
    Else
   ColorOfCF = Rng.FormatConditions(AC).Interior.Color
    End If
End If

End Function

'''''''''''''''''''''''''''''''''''''''

Function GetStrippedValue(CF As String) As String
    Dim Temp As String
    If InStr(1, CF, "=", vbTextCompare) Then
   Temp = Mid(CF, 3, Len(CF) - 3)
   If Left(Temp, 1) = "=" Then
     Temp = Mid(Temp, 2)
   End If
    Else
   Temp = CF
    End If
    GetStrippedValue = Temp
End Function
 

'''''''''''''''''''''''''''''''''''''''

Function CountOfCF(InRange As Range, _
    Optional Condition As Integer = -1) As Long
    Dim Count As Long
    Dim Rng As Range
    Dim FCNum As Integer

    For Each Rng In InRange.Cells
    FCNum = ActiveCondition(Rng)
    If FCNum > 0 Then
      If Condition = -1 Or Condition = FCNum Then
      Count = Count + 1
      End If
    End If
    Next Rng
    CountOfCF = Count
End Function

'''''''''''''''''''''''''''''''''''''''

Function SumByCFColorIndex(Rng As Range, CI As Integer) As Double
    Dim R As Range
    Dim Total As Double
    For Each R In Rng.Cells
    If ColorIndexOfCF(R, False) = CI Then
      Total = Total + R.Value
    End If
    Next R
    SumByCFColorIndex = Total
End Function


[/CODE]

Pichart Y. replied to Rowland Hamilton on 10-Feb-13 09:03 AM
Hi Rowland,

Sorry I haven't got time to follow all of what you have done. But here is some simple thing I though...hope this help you for your more elaborated coding.

--------------------------------------------------
Sub IndicateToTen()
    Range("G1").FormulaR1C1 = "TempField"
    Range("G2:G25").FormulaR1C1 = "=RANK(RC[-2],R2C5:R25C5)"
    For Each tmpVal In Range("G2:G25")
    If tmpVal < 11 Then
    Range("A" & tmpVal.Row & ":E" & tmpVal.Row).Interior.Color = 255
    End If
    Next tmpVal
    Range("G:G").Clear
End Sub
--------------------------------------------------------
indicateTop10.zip

Pichart Y.