I Need help to reconstruct code to add to existing code, please

[estatefinds]

1.This code below needs to be reconstructed to work on the active worksheet, not any others.
2. in a range of Q5 to U27 there will be 5 cells at a time that will be colored interior yellow.
3. I need to return the data of interior colored cell yellow to be recorded as for example 1-5-7-12-18 into column W starting at row 5.

4. so everytime I select; as you will see in the example file a combination in column A the data in the range H5 to L27 will colored interior yellow and the data in the Q5 to U27 will be colored interior yellow.

5. the range that i'm focusing on for the code below is the Q5 to U27, so I need the code Below to work with existing event code.


6. so Everytime I select a combination in column A the data in both ranges will be colored interior yellow, then I need the code below to be reconstructed so any cell that gets interior colored yellow, which 5 at the same time in the range Q5 to U27, that data within the cell will be recorded in column W starting at row 5. so it will look like this:
1-5-7-12-18

when you open file select the first combination in column A and youll see the cells being colored interior yellow as described above.
Also when you go back up to the first combination in column A look at the ranges where the cells are interior colored yellow in the range Q5 to U27 and then look over to the right in Column W I had placed the data of the colored interior yellow 1-5-7-12-18 manually so the data that is colored interior yellow as I Select each combination in Column A the data in the range Q5 to U27 will be recoreded in column W starting at row 5.
if any questions let me know. Thank you

any help on this is Appreciated!
Sincerely Dennis

Option ExplicitPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column <> 1 Then Exit Sub
    Application.EnableEvents = False
    Call Test2(Target)
    
    Application.EnableEvents = True
End Sub
 
 
Sub Test2(Target As Range)
    Dim R As Range, arr, a
    Dim cel As Variant
     
    Set R = Range("Q:U").SpecialCells(2)
    For Each cel In R
        If cel.Interior.ColorIndex = 6 Then
            cel.Interior.ColorIndex = xlNone
        End If
    Next
    
    Set R = Nothing
    
    Set R = Range("H:L").SpecialCells(2)
    For Each cel In R
        If cel.Interior.ColorIndex = 6 Then
            cel.Interior.ColorIndex = xlNone
        End If
    Next
    'Range("Q:U").Interior.ColorIndex = xlNone
    arr = Split(Target, "-")
    For Each a In arr
        Call DoFind(R, a)
    Next
   
End Sub


Sub DoFind(R, v)
Dim c, firstAddress
Dim Target As Range


    With R
        Set c = .Find(v, Lookat:=xlWhole)
        
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                If c.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = 6
                   
                If c.Interior.ColorIndex = 6 Then
                    If c.Offset(0, 9).Interior.ColorIndex = xlNone Then
                        c.Offset(0, 9).Interior.ColorIndex = 6
                    End If
                End If
                
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    
End Sub

THIS CODE ABOVE AND THE CODE BELOW I WOULD TO BE COMBINED, BUT OF COURSE WOULD LIKE THE CODE BELOW TO BE RESTRUCTRED AS DESCRIBED ABOVE. THANK YOU

Sub test()
Dim r As Range, cel As Range
Set r = Range(Sheets(“Sheet2”).Range(Q5:U27),Sheets(“Sheet2”).Range(Q5:U27” & rows.count).End(xlup))
For each cel In r
                                If cel Interior.Colorindex=6 Then
                                                Range(“Q5:U27”& rows.count). End(xlUp).offset(2).Value =cel.value
                End If
    Next  cel
End Sub

[mana]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column <> 1 Then Exit Sub
    If Target.Count > 1 Then Exit Sub

        If Not c Is Nothing Then
            firstAddress = c.Address
            
            Dim s As String
            s = c.Offset(0, 9).Value
            
            Do

                End If
                
                s = s & "-" & c.Offset(0, 9).Value
                Set c = .FindNext(c)
                If c Is Nothing Then Exit Do
            Loop While c.Address <> firstAddress
        End If
    End With
    
    Dim k As Long

    k = WorksheetFunction.Max(5, Cells(Rows.Count, "W").End(xlUp).Row + 1)
    Cells(k, "W").Value = s
        
End Sub

[estatefinds]

Thank you for assisting, I had redone code as you described in post number #2. it is recording the data incorrectly.

in post #1 open the file i had attached and look all the way to the column W that data is what is suppossed to look like. I did the first 5 manually.

so when I select the 1-2-3-7-9 in column A the ranges there will be five numbers highlighted . the first range is the numbers that make up the combination, so in range H5 to L27 the 1-2-3-7-9 will be interior colored yellow of the data of the uncolored cells.


now in the range Q5 to U27 that data that gets colored interior yellow of the uncolored data will have different numbers in the cells. this data that are colored yellow interior will be recorded for example in W starting in row 5 will be just the 1-5-7-12-18. then when I go down to the next combination in column A, and select the 1-2-4-6-11 the data in column W at row 6 gets recorded as 1-1-3-12-14.

let me know if this helps. thank you

[mana]

Option Explicit


Dim al As Object


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column <> 1 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    
    Application.EnableEvents = False
    Call Test2(Target)
    Application.EnableEvents = True
    
End Sub
 
 
Sub Test2(Target As Range)
    Dim R As Range, arr, a
    Dim cel As Variant
     
    Set R = Range("Q:U").SpecialCells(2)
    For Each cel In R
        If cel.Interior.ColorIndex = 6 Then
            cel.Interior.ColorIndex = xlNone
        End If
    Next
    
    Set R = Nothing
    
    Set R = Range("H:L").SpecialCells(2)
    For Each cel In R
        If cel.Interior.ColorIndex = 6 Then
            cel.Interior.ColorIndex = xlNone
        End If
    Next
    
    Set al = CreateObject("system.collections.arraylist")


    arr = Split(Target, "-")
    For Each a In arr
        Call DoFind(R, a)
    Next
    
    al.Sort
    Dim k As Long

    k = WorksheetFunction.Max(5, Cells(Rows.Count, "W").End(xlUp).Row + 1)
    Cells(k, "W").Value = Join(al.toarray, "-")
   
End Sub


Sub DoFind(R, v)
Dim c, firstAddress
Dim Target As Range

    With R
        Set c = .Find(v, Lookat:=xlWhole)
        
        If Not c Is Nothing Then
            firstAddress = c.Address

            Do
                If c.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = 6
                   
                If c.Interior.ColorIndex = 6 Then
                    If c.Offset(0, 9).Interior.ColorIndex = xlNone Then
                        c.Offset(0, 9).Interior.ColorIndex = 6
                        al.Add c.Offset(0, 9).Value
                    End If
                End If
                
                Set c = .FindNext(c)
                If c Is Nothing Then Exit Do
            Loop While c.Address <> firstAddress
        End If
    End With
      
End Sub

[estatefinds]

Thank you very much!!! it works Great!!! I appreciate your help on this Awsome Job!!