Highlight cells based on selected cell loop.

[JF123]

Similar to this thread

http://www.mrexcel.com/forum/showthread.php?t=616627

I am looking to highlight values based on a selected cell.

However, would also like the other values in the highlighted cell's row to be used as inputs for the next search and highlight those values as well.

Can anyone help this this macro tweak? Any questions let me know.

Thank you in advance.

 

[JF123]

Okay, thank you too Rick.

I really appreciate everyone's help.

If this book wasn't so large I would have done it manually, but I've been trying to solve for this for quite a while now.

JF

 

[Rick Rothstein]

Okay, thank you too Rick.

You may have missed it in crossing, but I edited my original message to ask you a question. Can you please go back to my previous message and answer that question for me?

 

[Cindy Ellis]

I suspect Rick can make this more efficient, but I'm reasonably sure it does what you're looking for:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'modified from code by taurean
Static sOldRng As Range
Dim ThisRow As Long, LastCol As Long, ValueCount As Long
Dim r As Range, c As Range, d As Range
Dim m, e

If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

ThisRow = Target.Row
LastCol = ActiveSheet.Cells(ThisRow, Columns.Count).End(xlToLeft).Column
If Not sOldRng Is Nothing Then
    With sOldRng
        .Font.ColorIndex = xlColorIndexAutomatic
        .Interior.ColorIndex = xlColorIndexNone
    End With
    Set sOldRng = Nothing
End If

With ActiveSheet
    Set m = CreateObject("scripting.dictionary")
    'Start with the values in the original row
    For Each c In .Range(.Cells(ThisRow, 1), .Cells(ThisRow, LastCol))
        If (Not m.Exists(c.Value)) And c.Value <> "" And c.Value <> 0 Then m.Add c.Value, 1
    Next c
    'as each cell is checked, add all values from that row to m, skipping values that are already there
    
    'repeat until nothing new is added
    Do
        ValueCount = m.Count
        For Each e In m
            For Each r In .UsedRange
                If r.Value = e Then
                    LastCol = ActiveSheet.Cells(r.Row, Columns.Count).End(xlToLeft).Column
                    For Each d In .Range(.Cells(r.Row, 1), .Cells(r.Row, LastCol))
                        If (Not m.Exists(d.Value)) And d.Value <> "" And d.Value <> 0 Then m.Add d.Value, 1
                    Next d
                End If
            Next r
        Next e
        
    Loop While m.Count > ValueCount 'this means something got added
'this goes through all the values again, so it's not particularly efficient, but it seems to work
For Each r In .UsedRange
    For Each e In m
        If r.Value = e Then
            If sOldRng Is Nothing Then
                Set sOldRng = r
            Else
                Set sOldRng = Union(sOldRng, r)
            End If
        End If
    Next e
Next r
End With

If Not (sOldRng Is Nothing) Then
    With sOldRng
        .Font.Color = vbRed
        .Interior.Color = vbYellow
    End With
End If

End Sub

Hope this helps,

 

[JF123]

Rick,

Yes, sorry missed that.

Once the Row 8 is set to highlight, if 5 was in it, then row 5 should have all cells highlighted, as if the new value 5 would be searched for from the top of the entire sheet.

Hope this helps.

JF

 

[JF123]

Thanks Cindy will take a look.

JF

 

[JF123]

Wow Cindy thanks !!!

I think this is it.

Cut and pasted and works. Haven't even gone through it yet, to see what was missing.

Eureka !!!

Thanks.

JF

 

[Cindy Ellis]

It wasn't just something missing...it needed a bit of a different approach.
Basically, it processes all the cells multiple times, which really could take a long time on large files :
First, it uses a scripting dictionary (a concept borrowed from Mr. Excel's book "Excel Gurus Gone Wild") to create a list of unique values from the target row. Then it processes each value in the list to add all the values from each row where it finds a value in the list.
It repeats this process until nothing new got added to the list.
Then, it goes through the used range once more to highlight all the values in the list.
A lot of chugging through data...but it does seem to work.

 

[JF123]

Stepped away for a second, but just wanted to take another moment and thank Cindy, Rick, and Taurean for posting the code that ultimately put this together.

I could not have done this without your excellent help.

Thanks again !!!

JF

 

[Rick Rothstein]

I suspect Rick can make this more efficient,

I did it a slightly different way and it seems faster than your code, more importantly, I think it may even work correctly. Testing it to see if it in fact does work is something JF123 can do. Me, I think I will be going to sleep soon so I'll check tomorrow to see JF123 analysis regarding if it works or not.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim RowArray As Variant, RowCells As Variant
  Dim Index As Long, DoneRows As String
  Dim UR As Range, Rng As Range, Coll As New Collection
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Set UR = ActiveSheet.UsedRange
  UR.Font.ColorIndex = 0 ' xlColorIndexAutomatic
  UR.Interior.ColorIndex = xlColorIndexNone
  If Len(Target.Value) = 0 Then GoTo Whoops
  On Error Resume Next
  RowArray = Intersect(Target.EntireRow, UR).Value
  DoneRows = DoneRows & " " & Target.Row
  If Err.Number Then GoTo Whoops
  For Each RowCells In RowArray
    If Len(RowCells) > 0 And RowCells <> 0 Then Coll.ADD RowCells, CStr(RowCells)
  Next
  Do While Index < Coll.Count
    Index = Index + 1
    UR.Replace Coll(Index), "=" & Coll(Index), xlWhole
    With UR.SpecialCells(xlFormulas)
      .Font.Color = vbRed
      .Interior.Color = vbYellow
      If InStr(" " & DoneRows & " ", " " & Rng.Row) = 0 Then
        For Each Rng In .Cells
          RowArray = Intersect(Rng.EntireRow, UR).Value
          For Each RowCells In RowArray
            If Len(RowCells) > 0 And RowCells <> 0 Then Coll.ADD RowCells, CStr(RowCells)
          Next
        Next
      End If
      .Replace "=", "", xlPart
    End With
  Loop
Whoops:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

 

[JF123]

Hi Rick,

Thank you again.

With your code, some cells were not highlighted, some of those cells contain values like "10:00:00:00:98:04:cd:00" without the quotations, there are others though that were missed as well. Not sure why, as these look normal to me like "MACHINENAME_1" without the quotes, though others in that row WERE highlighted.

Looks like this might have either hit an upper limit or stopped parsing after the first occurrence of cells like "10:00:00:00:98:04:cd:00".

JF