Formula or VBA for Cell Range of Values

[ststern45]

Hi everyone.

I have a range of 40 cells and in these 40 cells are a total of 4 values from 0 through 9.
The 40 cells will always have 4 values. No more no less.
If the 4 values in the 40 cells all touch either horizontal, vertically, etc. As long as each value touches one another.
Image 1:
Example where all 4 numbers touch each other.
The values 2-0-1-3 all touch. If the 4 numbers touch then a value of 1. If they don't a value of 0

Image 2:
1 or more numbers do not touch.
In this case the result would be false and a value of 0 (zero)
Even though the values 2, 0, and 5 touch the 4 does not so the result would be false of the value 0 (zero)

Thank you in advance!!

 

[ststern45]

Hi Eric & Alex,
I was away for a few days and just got back tonight. I will use the code from Alex on Wednesday. The only thing with using the VBA code is I have a large number of calculations to perform.
If this code could be a function.
I have some other ideas for Alex's code and will try them out Wednesday.
Thank you both for all your help.

 

[Alex Blakenburg]

Since I am using current region, I am not sure whether it will work as a function.
How is the data being populated (Formula or manual input) ?
If you are using a formula then I assume the cells that appear as blanks are really a null string ie "", is that correct ?
Are the cells always going to be numbers ?

 

[ststern45]

Just arrived home this evening.
Alex. Your code is fantastic.
I tried using your code on a 3 x 10 grid. (see attached image)
All 3 numbers must touch horizontally, or vertically, or diagonally.
A 3 x 10 has 4060 possible sets
There should be 272 sets where all 3 values touch.
When I ran you code (fantastic I must say) there were 17 sets that should have not been counted
1,6,8
11,13,18
11,15,16
14,16,21
14,18,19
17,19,24
17,21,22
2,4,9
2,6,7
20,22,27
20,24,25
23,25,30
23,27,28
5,7,12
5,9,10
8,10,15
8,12,13

I changed the values which may be why the results were off.
I ran all 4060 sets
Added additional code
I changed the following 2 lines to match a 3 x 10 grid
.
Set rngSrc = .Range("A2").Resize(10, 3)

If WorksheetFunction.CountA(cellFound.CurrentRegion) = 3 Then

Updated code below:

Sub Touch1()

Dim aRng As String

aRng = Sheets("Touch").Range("V8").Value

With ActiveSheet
For Each cll In .Range(aRng & Range("V1").Value & ":" & aRng & Range("V2").Value).Cells

.Range("V3").Value = cll.Value


Touch2


Next cll
End With

End Sub



Sub Touch2()

Dim ws As Worksheet
Dim rngSrc As Range, rngResult
Dim rngDest As Range, cellFound As Range


Application.ScreenUpdating = False

Set ws = ActiveSheet
With ws
Set rngSrc = .Range("A2").Resize(10, 3) '<--- Change this to the first Data cell ie left top corner below heading
Set rngResult = rngSrc.Cells(1, 1).Offset(, 5) '<--- Based on your image this is the offset to the result cell
Set rngDest = .UsedRange.Cells(1, 1).Offset(, .UsedRange.Columns.Count + 2).Resize(rngSrc.Rows.Count, rngSrc.Columns.Count)

rngDest.Value = rngSrc.Value
On Error Resume Next
Set cellFound = rngDest.Find(what:="*")
On Error GoTo 0
If cellFound Is Nothing Then
MsgBox "No Data In Data area"
Exit Sub
End If

If WorksheetFunction.CountA(cellFound.CurrentRegion) = 3 Then
rngResult.Value = 1
Else
rngResult.Value = 0
End If

rngDest.Clear

Dim resetUsedRange As Long
resetUsedRange = ws.UsedRange.Row

End With

Range("F2").Select
Application.CutCopyMode = False
Selection.Copy

Range("P" & Range("V5").Value).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

Range("G1").Select

Application.ScreenUpdating = True

End Sub


The 17 sets where probably my error in changing the wrong values in the 2 lines of code.

I will run the original code for the 4 x 10 grid tomorrow morning.

Thank you!!

 

[ststern45]

I calculated the values 1 through 16 and found 75 sets that should not be calculated as 1 instead it should be 0
I ran all 1325 sets using Alex's code.
From the 1325 sets Alex's code generated 297 sets where each of the 4 values touched vertically, horizontally, or diagonally. All 4 values must touch to qualify which would be the value 1.
I went through the same 1325 sets and came up with 222 sets where all 4 values touch.
There are 75 sets that should not result in a value of 1 instead they should be a 0.
These are the 1st 10 of the 75 sets:
1 2 5 11
1 2 7 9
1 3 6 12
1 3 7 10
1 3 8 10
1 4 7 10
1 6 11 13
1 6 9 15
1 7 10 11
1 7 10 12

I had an idea and wanted to get your opinion(s)
The attached image is the 4 x 10 grid
If I take the 1st set from above 1 2 5 11 and create 2 coordinates (C1 & C2) for each of the numbers 1 2 5 11
1 = 1,1 (C1, C2)
2 = 2,1
5 = 1,2
11 = 3,3

The values 1, 2, and 5 touch but the 11 does not touch either the 1, 2, 5 which should give this set 1 2 5 11 a value of 0
The question would be, using the coordinates from each of the values 1 2 5 11 be used to create a formula or vba to determine if a set is either a 0 or 1?

The Grid Coordinates image contain the C1 & C2 values based off of the grid values 1 through 40.

I ran the sets for 1 through 4 down to 13 through 16 which calculates to 1325 sets. I'm then use the position 1 values that contain 1, 2, 3, or 4.
Once I know what sets contain a 1 from the 1325 sets I just use the these results and copy them to the next grouping of 5, 6, 7, 8 down to 17, 18, 19 20 until I finish with the last sets of 25, 26, 27, 28 to 37, 38, 39 40.

Sorry for the long winded explanations.

Thank you.

 

[Eric W]

I still haven't figured out how to get the function to work, so I wrote up a UDF that seems to work:

Public MyResult As Byte

Public Function Touching(MyRange As Range, HowMany As Long)
Dim mydic As Object, c As Variant

    Application.Volatile
    MyResult = 0
    Set mydic = CreateObject("Scripting.Dictionary")
    For Each c In MyRange
        If c <> "" Then
            mydic(c.Row * 1000 + c.Column) = 1
        End If
    Next c
    If mydic.Count <> HowMany Then
        Touching = "Not exactly " & HowMany & " filled cells"
        Exit Function
    End If
    
    Call recur(mydic, Array(1, -1, 999, -999, 1000, -1000, 1001, -1001))
    
    Touching = MyResult
    
End Function

Public Sub recur(ByVal mydic, ByVal offsets)
Dim c As Variant, x As Variant, y As Variant, dic2 As Object
    
    If mydic.Count = 1 Then
        MyResult = 1
        Exit Sub
    End If
    
    For Each c In mydic
        For Each x In offsets
            If MyResult = 1 Then Exit Sub
            If mydic.exists(c + x) Then
                Set dic2 = CreateObject("Scripting.Dictionary")
                For Each y In mydic
                    If y <> c Then dic2(y) = 1
                Next y
                Call recur(dic2, offsets)
            End If
        Next x
    Next c
        
End Sub

You call it by using this function on the worksheet:

=Touching(A2:D11, 4)

where the range is the area in question, and the 4 is how many cells are required to touch.

 

[ststern45]

Thank you Eric.
I'm away from my computer until this coming Friday.
I will check out your work.
Thank you so much.
Steve

 

[ststern45]

I had a few minutes before I had to leave today.
The code works to perfection.
I ran all the sets and 100% accurate.

Thank you, Thank you, Thank you (a million times)

 

[Eric W]

Glad we could help.