# find 3 non contiguous cells with input box

#### maniniinfotech

##### Member
Hi i need to find 3 cells values in the given range i.e (R1:AG169) in any direction with input box
as am attaching two attachments in sheet 3 i need the code to find 3 cells
i have highlighted the cells so that u can understand result expected

thank you in advance and if any mistakes while explaining please ignore

#### Attachments

• 188.7 KB Views: 14
• 189.5 KB Views: 13

#### maniniinfotech

##### Member
locate the first value
then for each direction check if the near cell is equal to the second value,
if yes go on for the third and so on … When 4 cells are matching, highlight them.

#### Marc L

##### Excel Ninja
Hi, give a sample of the input box entry …​

#### maniniinfotech

##### Member
in temp result before.xls , sheet 3
numbers are
5,8,2
1,6,1
4,2,2
7,1,0
to be found
i donot know how to use input box for 3 numbers or more

#### Marc L

##### Excel Ninja
As an input box is nothing else than a text entry, you must use a text separator like a space, a comma, …​

#### Kenneth Hobson

##### Active Member
Looks more like what you want is opposite of subject line.

For continuous integer cell values:
Code:
``````Sub Test_birStarMatch()
Dim c As Range, r As Range, a
'a = Split("5 7 3")
a = Split(InputBox("Enter sequence separated by space characters. e.g. 5, 7, 3", "Sequence"))
Set c = Range("R1:AG169")
Set r = briStarMatch(a, c)
c.Interior.Color = xlNone
If Not r Is Nothing Then
r.Interior.Color = vbYellow
End If
End Sub

'Big Range Integer values in array aV Star Match (all directions like a star)
'e.g. Array(1,5,33) up, down, left, right and 4 diagonals with the 3 integer values sequential
Function briStarMatch(aV, BigRange As Range) As Range
Dim r As Range, c As Range, f As Range
On Error Resume Next
For Each c In BigRange
Set r = riStarMatch(c, aV, BigRange)
If f Is Nothing Then Set f = r
Set f = Union(f, r)
Next c
If Not f Is Nothing Then Set briStarMatch = f
End Function

'Return Range with Matrix Matched values from 0 base array aV in all directions from one cell, bR.
Function riStarMatch(bR As Range, aV, BigRange As Range) As Range
Dim c As Range, r As Range, j, i As Integer, cc As Range

If bR <> CInt(aV(0)) Then Exit Function

'array element count, j
j = 1 + UBound(aV)

On Error Resume Next

With bR
'Left match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i * -1))
Next i
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top Left Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top Right Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Right match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom Right Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom Left Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
End With

If Not r Is Nothing Then Set riStarMatch = r
End Function

Function InRange(BigRange, LittleRange) As Boolean
Dim r As Range
On Error Resume Next
Set r = Intersect(BigRange, LittleRange)
If r.Count = LittleRange.Count Then InRange = True
End Function``````

#### maniniinfotech

##### Member
Hi Marc L you give any option it should highlight the entered numbers
thats the requirement and numbers,range will be changing

Last edited:

#### maniniinfotech

##### Member
Hi Kenneth Hobson sir it is not working, if i input the numbers nothing happened should i select the range

#### Marc L

##### Excel Ninja
numbers,range will be changing
That's confusing as it seems to be the opposite of the initial post​
so without any crystal clear & complete explanation of the need I won't try anything …​

#### Kenneth Hobson

##### Active Member
What numbers did you try? Did you try the example numbets and separate by space characters as required?

#### Marc L

##### Excel Ninja
Hi Kenneth Hobson sir it is not working, if i input the numbers nothing happened
As Kenneth's procedure well works on my test workbook (as I can't open your attachment on my usual test computer) …​

#### Marc L

##### Excel Ninja
As an input box is nothing else than a text entry, you must use a text separator like a space, a comma, …
If the cells always contain only a single digit then a separator is even not necessary !​
I was thinking about a shorter code around 80 codelines with each direction detailled​
but after a mix optimization the standalone procedure needs around 50 codelines​
with the initial requirement of both horizontal directions can be splitted in several rows​
without any error trapping neither any call to some VBA function and for each direction a color …​
But it depends too on the explanation still expected since posts #7 & #9.​

#### maniniinfotech

##### Member
sheet 3 and the range is R1:AG179
numbers to be found
9,5,0
6,1,5
7,0,8
9,6,8

i think it should search the range which is selected because the numbers keep on adding day to day, u can cant change the range everytime

#### Attachments

• 189.6 KB Views: 3

#### Marc L

##### Excel Ninja
and the range is R1:AG179
If the range always starts from cell R1, no matters if only columns Q & AH are still empty, right ?​

numbers to be found 9,5,0 | 6,1,5 | 7,0,8 | 9,6,8
Are always the same sequences numbers to search for or they can change ?​
Imagine you search first a sequence, the matching cells are color highlighted :​
for the next sequence to search, the range must be reinitialized by default without any color​
or previous result must stay as it is ? 'Cause the more colored sequences, the less readibility …​
Or maybe you prefer to search several sequences at once ? Easy if they are always the same​
and if not, the sequences must be entered via an input box with a space delimiter like 950 615 708 968
and whatever the result direction : a sequence, a color like 950 615 708 968 (background colors).​
If you enter a single sequence : a direction, a color …​
Well think about your need as I will post an one shot code : I won't amend it if you forgot anything.​
As a reminder : the better explanation, the better and more targeted answer …​

#### maniniinfotech

##### Member
Hi Marc L numbers and sequences will be changing
i will be searching one by one
for one sequence or one set like 950 one colour is enough

(the sequences must be entered via an input box with a space delimiter like 950 615 708 968
and whatever the result direction : a sequence, a color like 950 615 708 968 (background colors).
If you enter a single sequence : a direction, a color …)

this is right

thank you so much

501
328
178
902

should be found

#### Attachments

• 189.6 KB Views: 4
Last edited:

#### Marc L

##### Excel Ninja
As I wrote « If the cells always contain only a single digit » so I assume it's true but you forgot one point :​
If the range always starts from cell R1, no matters if only columns Q & AH are still empty, right ?
And on my side I forgot to warn it will be a Windows only code, ok ?​

#### Kenneth Hobson

##### Active Member
I am still not sure that you have fully defined what you want. I would suggest that you modify your file so that it does not take so long to update on open. Formulas take long enough but with the numbers to text errors, those take even longer. Yours took almost 10 minutes to update on my computer on open. So that others can more easily test on the same data, I removed those errors and made an example with just your data values.

If you could not run the first example, I am not sure how you can run this one. I left the inputbox line commented out so that just running the test code with test sheet active, it will "work". All that is left for you to do for your file is copy mMain module to your file and set the colors in the aC array. That is if the 4 that you set is not what you want or want to add more or rearrange.

Code:
``````Sub Test_birStarMatch2()
Dim c As Range, r As Range, a, aC, i As Integer, b

aC = Split("1137094 65535 11573124 8696052")  'colors

a = Split("950 615 708 968")
'a = Split("615")
'a = Split(InputBox("Enter sequence separated by space characters. e.g. 950 615 708 968", "Sequence"))

Set c = Range("R1:AG170")

For i = 0 To UBound(a)
b = aSingleIntegers(a(i))
Set r = briStarMatch(b, c)
If i = 0 Then c.Interior.Color = xlNone
If Not r Is Nothing Then
r.Interior.Color = aC(i)
End If
Next i
End Sub

'Big Range Integer values in array aV Star Match (all directions like a star)
'e.g. Array(1,5,33) up, down, left, right and 4 diagonals with the 3 integer values sequential
Function briStarMatch(aV, BigRange As Range) As Range
Dim r As Range, c As Range, f As Range
On Error Resume Next
For Each c In BigRange
Set r = riStarMatch(c, aV, BigRange)
If f Is Nothing Then Set f = r
Set f = Union(f, r)
Next c
If Not f Is Nothing Then Set briStarMatch = f
End Function

'Return Range with Matrix Matched values from 0 base array aV in all directions from one cell, bR.
Function riStarMatch(bR As Range, aV, BigRange As Range) As Range
Dim c As Range, r As Range, j, i As Integer, cc As Range

If bR <> CInt(aV(0)) Then Exit Function

'array element count, j
j = 1 + UBound(aV)

On Error Resume Next

With bR
'Left match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top Left Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Top Right Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Right match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom Right Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If

'Bottom Left Diagonal match
Set c = bR  'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
End With

If Not r Is Nothing Then Set riStarMatch = r
End Function

Function InRange(BigRange, LittleRange) As Boolean
Dim r As Range
On Error Resume Next
Set r = Intersect(BigRange, LittleRange)
If r.Count = LittleRange.Count Then InRange = True
End Function

Function aSingleIntegers(s)
Dim a, i As Integer
ReDim a(0 To Len(s) - 1)
For i = 0 To Len(s) - 1
a(i) = CInt(Mid(s, i + 1, 1))
Next i
aSingleIntegers = a
End Function``````

#### Attachments

• 157.1 KB Views: 3

#### maniniinfotech

##### Member
Hi Marc L your assumption is right and cells contain only single digits ,
range starts from R1 and Q,AH are empty , i need windows only
Kindly provide the code for specifying range as selection

Last edited:

#### maniniinfotech

##### Member
Hi Kenneth Hobson Sir it is working awesome and how do i get the input box as am able run the code
can i change the range by selecting now it is from (R1:AG170) the range will be changing day by day
thank you so much for the support provided by you sir

#### Marc L

##### Excel Ninja
• Better is to paste this tiny standalone demonstration to the Sheet3 worksheet module.
• This is a Windows version only but can be easily amended for MAC / Windows replacing `RegExp` by `StrConv` for example …

• The dynamic search range always starts from cell R1 and columns Q & AH must be always empty.
• The search range is initialized without any background color after the validation of the input box.

• If several sequences to search, at least a space must separate each one in the input box.
• A number sequence must contain at least two digits.

• A horizontal sequence can be split between two rows (same way of your previous thread).

• For several sequences to search : a sequence, a background color. For a single sequence : a direction, a background color …

Code:
``````Sub Demo1()
Dim S\$(), oReg As Object, D&, Num As Object, U&, Rf As Range, A\$, B%, K&, L&, R&, C&, P&, V, Rg As Range, N&, T&, W
S = Split(Application.Trim(InputBox(vbLf & vbLf & "Enter numbers delimited by a space :", "HighLight Sequence", "501 328 178 902")))
If UBound(S) < 0 Then Exit Sub
Set oReg = CreateObject("VBScript.RegExp"):  oReg.Global = True:  oReg.Pattern = "\d"
With [R1].CurrentRegion.Columns
.Interior.ColorIndex = xlNone
Application.ScreenUpdating = False
For D = 0 To UBound(S)
Set Num = oReg.Execute(S(D))
U = Num.Count - 1
If U > 0 Then
Set Rf = .Find(Num(0), , xlValues, xlWhole, xlByRows)
If Not Rf Is Nothing Then
B = 44 - D
K = .Count + 1 - U
L = .Cells.Count + 1 - U
R = .Rows.Count + 1 - U
Do
C = Rf.Column + 1 - .Column
P = C + (Rf.Row - 1) * .Count
For Each V In Array(Array(P > U, -1), Array(P < L, 1))
If V(0) Then
Set Rg = Rf
For N = 1 To U
If .Cells(P + N * V(1)).Text = Num(N) Then Set Rg = Union(.Cells(P + N * V(1)), Rg) Else Exit For
Next
If N > U Then Rg.Interior.ColorIndex = IIf(UBound(S), B, 34 + (V(1) < 0)): T = T + 1
End If
Next
For Each V In Array(Array(Rf.Row > U, -1, 35), Array(Rf.Row < R, 1, 38))
If V(0) Then
For Each W In Array(Array(True, 0), Array(C > U, -1), Array(C < K, 1))
If W(0) Then
Set Rg = Rf
For N = 1 To U
If Rf(1 + N * V(1), 1 + N * W(1)).Text = Num(N) Then Set Rg = Union(Rf(1 + N * V(1), 1 + N * W(1)), Rg) Else Exit For
Next
If N > U Then Rg.Interior.ColorIndex = IIf(UBound(S), B, V(2) - (W(1) <> 0) - (W(1) > 0)): T = T + 1
End If
Next
End If
Next
Set Rf = .FindNext(Rf)
End If
End If
Next
End With
Application.ScreenUpdating = True
Set oReg = Nothing:  Set Num = Nothing:  Set Rf = Nothing:  Set Rg = Nothing
If T = 0 Then MsgBox "Sequence not found …", vbInformation, "HighLight"
End Sub``````
Do you like it ? So thanks to click on bottom right Like !​

#### maniniinfotech

##### Member
sorry Marc L, i had not refreshed the screeen before posting the previous statement
thank you so much for the code

#### Kenneth Hobson

##### Active Member
There are 2 ways to make c range 100% dynamic. (1) Application.InputBox() or (2) Selection. Here is the later:
Code:
`````` a = Split(InputBox("Enter sequence separated by space characters. e.g. 950 615 708 968", "Sequence"))
Set c = Selection``````
A semi-dynamic way would be a method where limits as Marc used where a starting cell and limits such as blank or such define extents.

#### maniniinfotech

##### Member
Hi Marc L it is awesome and superb thank you so much

#### maniniinfotech

##### Member
Hi Kenneth Hobson sir thank you so much, code is awesome

#### maniniinfotech

##### Member
Hi Marc L and Kenneth Hobson sir
i do have a doubt in another aspect am uploading the file