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!!! :clap: I appreciate your help on this Awsome Job!!