i have this vba- excel problem im stuck on for days , i can really use some help.

i have a numbers table within a dynamic range (different for every time a button is beeing prresed.) the table is spread along the entire range.. and i need within that tables to find three numbers who are :

1. even
2. the avg of those 3 nums is one of them (of the nums)

after finding that trio , i need to color them in the table and print a msgbox who states the areas boundris ( 4X3 for example..) and the fact that this trio exists and also the num who is the avg.

im only having a problem with finding that trio and somehow store it. any kind of help will be great.

this is what i have so far :

Private Sub CommandButton2_Click()
Dim rng As Range
Set rng = Range("a1").CurrentRegion
Dim cell As Range
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
x = rng.Rows.Count
y = rng.Columns.Count

For Each cell In rng
  If Not (cell.Value Mod 2 = 0) Then cell.Value = ""
    Next cell
    
    For Each cell In rng
    For i = 1 To rng.Rows.Count
    For j = 1 To rng.Columns.Count
        
        If Cells(i, j) - cell.Value = Abs(cell.Value - Cells(i, j)) Then
           
                Cells(i, j).Interior.Color = vbYellow
                MsgBox "the area is" & "" & x & "X" & y & vbNewLine & "there are 3 special nums" & vbNewLine & "avarege is " & "" & cell.Value
                End If
                Next j
                Next i
                Next cell
                
                 
                 MsgBox "the area is" & "" & x & "X" & y & vbNewLine & "there are no speacial nums"
                 
                 End Sub

the range can not be more then a few rows or coulmns. also , the trio can be anywhere in the table . the idea is to recognzie the trio that meet the mentiond requirements.

CodePudding user response：

I think best approach would be to get rid first of odd values and then ignoring duplicated data and then try trios of remaining numbers. Anyways, please, notice that depending on how many different values you got, performance can be affected.

Also, notice that because your data got duplicates, sometimes you could get highlited more than 3 cells.

Be sure your activecell is inside the range to check for this code to work!

Before code:

After code:

Sub test()
Dim rng As Range
Dim MyNumbers() As Double
Dim Dict As Object
Dim MyKey As Variant
Dim i As Long
Dim j As Long
Dim k As Long



Set Dict = CreateObject("Scripting.Dictionary")

'this will work based on active cell. It will take complete region

For Each rng In ActiveCell.CurrentRegion
    'get rid of odd elements
    If Dict.Exists(rng.Value) = False And rng.Value / 2 = Int(rng.Value / 2) Then Dict.Add rng.Value, 0
Next rng

ReDim MyNumbers(1 To Dict.Count)

i = 1
For Each MyKey In Dict.Keys
    MyNumbers(i) = MyKey
    i = i   1
Next MyKey

Dict.RemoveAll


For i = 1 To UBound(MyNumbers) - 2 Step 1
    For j = (i   1) To UBound(MyNumbers) - 1 Step 1
        For k = (j   1) To UBound(MyNumbers) Step 1
            If (MyNumbers(i)   MyNumbers(j)   MyNumbers(k)) / 3 = MyNumbers(i) Or _
            (MyNumbers(i)   MyNumbers(j)   MyNumbers(k)) / 3 = MyNumbers(j) Or _
            (MyNumbers(i)   MyNumbers(j)   MyNumbers(k)) / 3 = MyNumbers(k) Then
                'there is a match, we save that part
                Dict.Add MyNumbers(i), 0
                Dict.Add MyNumbers(j), 0
                Dict.Add MyNumbers(k), 0
                MsgBox "There is a match." & vbNewLine & "Area is " & ActiveCell.CurrentRegion.Rows.Count & "x" & ActiveCell.CurrentRegion.Columns.Count
                GoTo Result
            End If
            
        Next k
    Next j
Next i

'there is no match
MsgBox "There is a match." & vbNewLine & "Area is " & ActiveCell.CurrentRegion.Rows.Count & "x" & ActiveCell.CurrentRegion.Columns.Count
GoTo Final

Result:
For Each rng In ActiveCell.CurrentRegion
    'highlight numbers in dict
    If Dict.Exists(rng.Value) = True Then rng.Interior.Color = vbYellow
Next rng

Final:
Erase MyNumbers
Set Dict = Nothing

End Sub