Help with counting cells

[Imdurwood]

Hello everyone,
I need help counting cells which are next to or touching hi-glighted cells.. See below:



Note the counts in column AA. These are the total counts for each number that appear in the table. I need help with counting
how many times each number touches a hi-lighted cell...

For example, take the hi-lighted number 3 in C11. The numbers 8, 2.,7,1,4 are touching it and not any other hi-lighted cells. for the numbers 8, 2, 7, 1, 4. each of these numbers should be incremented 1 in column AB which is for numbers touching only 1 hi-lighted number. The numbers 4,4,1 are also touching cell C11, but are also touching the hi-lighted 5 in cell C13. These numbers should be incremented 1 in column AC, for numbers touching 2 hi-lighted cells.

So take the number 1... in the table above, it touches only only one hi-lighted cell 3 times, and two or more hi-lighted cells 14 times.



Can someone help me with a macro or formula which will do this for all the numbers?

any and all help would be greatly appreciated!!! Thank You,
Dave

 

[shamimarita]

Hello Imdurwood,

To count how many times each number touches highlighted cells in your dataset, you can use a VBA macro.

Sub CountTouchingCells()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
    Dim r As Range, cell As Range
    Dim highlightCell As Range
    Dim x As Long, y As Long
    Dim countSingle As Long, countMultiple As Long
    
    ' Loop through each cell in the range
    For Each cell In ws.Range("B10:Z18") ' Adjust range as needed
        If cell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
            For x = cell.Row - 1 To cell.Row + 1
                For y = cell.Column - 1 To cell.Column + 1
                    If ws.Cells(x, y).Interior.ColorIndex <> 6 And ws.Cells(x, y).Value <> "" Then
                        Dim touchingValue As Variant
                        touchingValue = ws.Cells(x, y).Value
                        
                        If Application.WorksheetFunction.CountIf(ws.Range("AA10:AA18"), touchingValue) > 0 Then
                            If CountHighlightedCells(ws, x, y) = 1 Then
                                countSingle = countSingle + 1
                            Else
                                countMultiple = countMultiple + 1
                            End If
                        End If
                    End If
                Next y
            Next x
        End If
    Next cell
    
    ' Output results
    ws.Range("AB1").Value = countSingle ' Change the output cell as needed
    ws.Range("AC1").Value = countMultiple ' Change the output cell as needed
End Sub

Function CountHighlightedCells(ws As Worksheet, x As Long, y As Long) As Long
    Dim count As Long
    Dim highlightCell As Range
    Dim cell As Range

    ' Check adjacent cells for highlights
    For Each highlightCell In ws.Range(ws.Cells(x - 1, y), ws.Cells(x + 1, y))
        If highlightCell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
            count = count + 1
        End If
    Next highlightCell

    CountHighlightedCells = count
End Function

This code will check each cell to identifiy its neighbors, then it will count the occurrences based on whether they touch highlighted cells. Adjust the ranges and highlight color as necessary.

 

[Imdurwood]

Hi Shamima,
Thank you for your work compiling that code for me! You're very kind.

First I want to say I am not very good at VBA.. I'm so so with regular Excel formulas, but not so much with VBA.. Having said this, here is what I did:
In the code, I noticed where you mentioned area's that I needed to modify to correspond with my particular worksheet.. I think I got everything updated... below is what I did:
1. changed sheet name... the worksheet name is "RD Working"
2. The range of the cells is B10:X18.. I changed this in the code, it was B10:Z18
3. There was also another range which was not right, it's about halfway down in the code, range was AA10:AA18. I changed it to AA9:AA18
4. in the Output results section, ws.range was "AB1 and "AC1".. I changed both parts to "AB9" and "AC9"
5. In the worksheet, I modified the Conditional formatting rules so that my highlight colors were all Yellow.
6. I had to change the type of Excel format I was using to Excel Macro-Enabled Workbook... Resaved it as that.

My other problem is, I'm not exactly sure where or how I should save this Macro you sent me? From what I know, not 100% sure though, I did this to save it to my workbook:
1. I right clicked on the sheet name tab at the bottom of the window,
2. clicked on "View Code"
3. Found the sheet name in the list... it was highlighted already, then I pasted in the general section...
Also created a Module 1 and inserted the code there.... both of these didn't produce desired results... they only put 0 0 in cells AB9 and AC9 :



Here is the code and changes I made:

Sub CountTouchingCells()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("RD Working") ' Change to your sheet name"
Dim r As Range, cell As Range
Dim highlightCell As Range
Dim x As Long, y As Long
Dim countSingle As Long, countMultiple As Long

' Loop through each cell in the range
For Each cell In ws.Range("B10:X18") ' Adjust range as needed
If cell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
For x = cell.Row - 1 To cell.Row + 1
For y = cell.Column - 1 To cell.Column + 1
If ws.Cells(x, y).Interior.ColorIndex <> 6 And ws.Cells(x, y).Value <> "" Then
Dim touchingValue As Variant
touchingValue = ws.Cells(x, y).Value

If Application.WorksheetFunction.CountIf(ws.Range("AA9:AA18"), touchingValue) > 0 Then
If CountHighlightedCells(ws, x, y) = 1 Then
countSingle = countSingle + 1
Else
countMultiple = countMultiple + 1
End If
End If
End If
Next y
Next x
End If
Next cell

' Output results
ws.Range("AB9").Value = countSingle ' Change the output cell as needed
ws.Range("AC9").Value = countMultiple ' Change the output cell as needed
End Sub

Function CountHighlightedCells(ws As Worksheet, x As Long, y As Long) As Long
Dim count As Long
Dim highlightCell As Range
Dim cell As Range

' Check adjacent cells for highlights
For Each highlightCell In ws.Range(ws.Cells(x - 1, y), ws.Cells(x + 1, y))
If highlightCell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
count = count + 1
End If
Next highlightCell

CountHighlightedCells = count
End Function


Can you outline for me the steps I need to take to make sure I'm saving it put the code in the right place within my worksheet??

At the risk wearing out my welcome, would it be possible for you to add to the code that when ever the cells change to different highlighted
numbers, the old results are cleared out and the code is run again automatically?

Thank you sooo much again for all your help!!!!
Dave

 

[shamimarita]

Hello Imdurwood,

It looks like you’ve done a lot of steps correctly! Here's how to ensure the macro works and to modify the code for your additional requests:

Steps to Save and Run the Macro:

• To open VBA editor press ALT + F11.
• In the VBA editor, click Insert >> Module.
• Paste the full macro code into this module.
• Press F5 or go to Developer tab >> from Macro >> select the Sub-Procedure.

Make sure the code is saved in a module, not directly within the worksheet's code window. If the code is inside the worksheet-specific module (which is what happens if you right-click the sheet and view code), it may not behave as expected.

You can use the Worksheet_Change event to automatically clear old results and rerun the macro whenever cells are updated.

Here’s how you can modify the macro:
Clear Old Results: Before starting the loop, clear columns AB and AC.
Automatically Re-Run: Place the macro inside the Worksheet_Change event so that it automatically runs whenever you change cells.
Here’s the updated macro:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B10:X18")) Is Nothing Then
        Call CountTouchingCells
    End If
End Sub

Sub CountTouchingCells()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("RD Working")
    Dim r As Range, cell As Range
    Dim x As Long, y As Long
    Dim countSingle As Long, countMultiple As Long
    
    ' Clear previous results
    ws.Range("AB9:AB18").ClearContents
    ws.Range("AC9:AC18").ClearContents
    
    ' Loop through each cell in the range
    For Each cell In ws.Range("B10:X18")
        If cell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
            For x = cell.Row - 1 To cell.Row + 1
                For y = cell.Column - 1 To cell.Column + 1
                    If ws.Cells(x, y).Interior.ColorIndex <> 6 And ws.Cells(x, y).Value <> "" Then
                        Dim touchingValue As Variant
                        touchingValue = ws.Cells(x, y).Value
                        
                        If Application.WorksheetFunction.CountIf(ws.Range("AA9:AA18"), touchingValue) > 0 Then
                            If CountHighlightedCells(ws, x, y) = 1 Then
                                ws.Cells(touchingValue + 9, 28).Value = ws.Cells(touchingValue + 9, 28).Value + 1 ' AB column
                            Else
                                ws.Cells(touchingValue + 9, 29).Value = ws.Cells(touchingValue + 9, 29).Value + 1 ' AC column
                            End If
                        End If
                    End If
                Next y
            Next x
        End If
    Next cell
End Sub

Function CountHighlightedCells(ws As Worksheet, x As Long, y As Long) As Long
    Dim count As Long
    Dim highlightCell As Range

    ' Check adjacent cells for highlights
    For Each highlightCell In ws.Range(ws.Cells(x - 1, y), ws.Cells(x + 1, y))
        If highlightCell.Interior.ColorIndex = 6 Then ' Assuming yellow highlight
            count = count + 1
        End If
    Next highlightCell

    CountHighlightedCells = count
End Function

Key Changes:
Worksheet_Change: This automatically triggers the macro whenever changes are made in the specified range.
Clearing Old Results: Before running, it clears the cells in columns AB and AC.
Dynamic Output: It dynamically adds the counts to columns AB and AC based on the touching cells.

 

[Imdurwood]

Well, I'm frustrated.. it's not working.
In my checking and double checking efforts to figure out why I discovered a possible issue which I previously overlooked.. in the range B10:X18 there will be times when a number doesn't touch any highlighted cells. Not sure if this is the reason why the code isn't working?

I am attaching an example spreadsheet. In I have made notes and explanations. For the the numbers that don't touch a highlighted cell,
just put in "V" in the cell's in Columns AB and AC for those numbers.

I hope you can figure out what the problem is? I appreciate all your work you're putting into this project for me!!
Dave