• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

find 3 non contiguous cells with input box

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

  • temp result before.xlsm
    188.7 KB · Views: 14
  • temp result expected.xlsm
    189.5 KB · Views: 13
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.
 
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
 
As an input box is nothing else than a text entry, you must use a text separator like a space, a comma, …​
 
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
    'MsgBox r.Address
    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
 
Hi Marc L you give any option it should highlight the entered numbers
thats the requirement and numbers,range will be changing
 
Last edited:
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.​
 
Hi Marc L i am uploading another file
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

  • temp result before (1).xlsm
    189.6 KB · Views: 3
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 …​
 
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

please see the attachement
501
328
178
902

should be found
 

Attachments

  • temp result before (1).xlsm
    189.6 KB · Views: 4
Last edited:
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 ?​
 
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

  • Sequence Markups.xlsm
    157.1 KB · Views: 4
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:
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
 
  • 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
          A = Rf.Address
          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)
        Loop Until Rf.Address = A
       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 !​
 
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.
 
Hi Marc L and Kenneth Hobson sir
i do have a doubt in another aspect am uploading the file
please go through the attachment
file doesn't respond and becomes very slow while operating
kindly provide me any solution to it
 

Attachments

  • COLOUR CODE & RESULT -.xlsx
    126.4 KB · Views: 1
Back
Top