georgiboy I can't seem to get your code to work right? The first dynamic code just colours the selection to be searched for. The second code errors or colours the wrong cells? Maybe I have misunderstood the task? I thought U selected a range to search, then selected a range of values to search for. Anything with those values within the range to search is colored. My first post just allowed for a one cell search as I hadn't quite appreciated the magnitude of the task. I messed around with some array code that adds some bells and whistles for error protection. Uses a lot of code/webspace but I thought I might as well post it anyways. Good luck. Dave
Option Explicit
Sub Find_Multiple_Values()
Dim Answer As VbMsgBoxResult, cnt As Integer
Dim Arr() As Variant, EditArr() As Variant, r As Range, r2 As Range
Dim rngToSearch As Range, LookUprng As Range
Answer = MsgBox("Are you sure you want to run the macro?", vbYesNo, "Run Find_Multiple_Values Macro")
If Answer = vbYes Then
'enter Data Range
On Error Resume Next
Set rngToSearch = Application.InputBox("Select Data Range", "Obtain Range", Type:=8)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Enter Range to search!"
Exit Sub
End If
'clear rngtosearch interior color to normal
rngToSearch.Interior.Color = xlNone
MsgBox "The cells selected were " & rngToSearch.Address
'enter search range
On Error Resume Next
'lookup range doesn't need to be in rngtosearch
Set LookUprng = Application.InputBox("Lookup Values", "Select Lookup Values", Type:=8)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Enter Look up range!"
Exit Sub
End If
MsgBox "The cells selected were " & LookUprng.Address
'load Array with lookup range values
cnt = 0
For Each r In LookUprng
ReDim Preserve Arr(cnt + 1)
Arr(cnt) = r.Text
cnt = cnt + 1
Next r
'create unique list of values
EditArr = UniqueArr(Arr)
'color matching values of unique values and rngtosearch
For cnt = LBound(EditArr) To UBound(EditArr)
For Each r In rngToSearch
'to cancel coloring of lookuprng selection
'For Each r2 In lookupRng
'If r2.Address = r.Address Then
'GoTo below
'End If
'Next r2
If EditArr(cnt) = r.Text Then
r.Interior.Color = RGB(255, 255, 0)
End If
below:
Next r
Next cnt
End If
End Sub
Function UniqueArr(InArr As Variant) As Variant
'returns array of unique values from inputted array
Dim cnt As Integer, cnt2 As Integer, cnt3 As Integer, Temparr() As Variant
For cnt = UBound(InArr) - 1 To LBound(InArr) Step -1
For cnt2 = cnt - 1 To 0 Step -1
If InArr(cnt) = InArr(cnt2) Then
GoTo below
End If
Next cnt2
ReDim Preserve Temparr(cnt3)
Temparr(cnt3) = InArr(cnt)
cnt3 = cnt3 + 1
below:
Next cnt
UniqueArr = Temparr
End Function