Appendix Thread. ( Codes for other Threads, etc.) Event Coding Drpdown Data validation

**DocAElstein** · 03-19-2020, 05:54 PM

In support of these posts
http://www.excelfox.com/forum/showth...ge40#post12669
http://www.eileenslounge.com/viewtop...=34247#p265646

Code:

' _   Marz 2020
Sub DeviceManagerPropertiesMarz172020()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDMP As Worksheet: Set WsDMP = Worksheets("DeviceManagerProperties")
Dim rngDMP1 As Range, rngDMP2 As Range  '           B1:F550          G1:J550
 Set rngDMP1 = WsDMP.Range("B5:F550"): Set rngDMP2 = WsDMP.Range("G5:J550")
' take each cell in range for original DMP and find it in range for new DMP but find next if the interior is already coloured
Dim Rng As Range
    For Each Rng In rngDMP1 '----------------------|
        If Rng <> "" Then
        Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
        Dim FndRng As Range
         Set FndRng = rngDMP2.Find(what:=Rng.Value, After:=rngDMP2.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
                Do While Not FndRng Is Nothing ' ===
                    If FndRng.Interior.ColorIndex = -4142 Then  ' case "virgin "white"" text
                     FndRng.Select
                     Let FndRng.Interior.ColorIndex = ClrIdx
                     Application.Wait (Now + TimeValue("00:00:01"))
                     
                     Rng.Select
                     Let Rng.Interior.ColorIndex = ClrIdx
                     Application.Wait (Now + TimeValue("00:00:01"))
                     Set FndRng = Nothing ' This will force the Loop to end after a succesful match
                    Else ' The cell already has background color, so try again from next row
                     Set FndRng = WsDMP.Range("G" & FndRng.Row + 1 & ":J550").Find(what:=Rng.Value, After:=WsDMP.Range("J550"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '   https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                    End If
                Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng '------------------------------------|

End Sub