How to count number of cells in Selection with VBA but count a Merged Cell as only 1

mcomp72

Board Regular
Joined
Aug 14, 2016
Messages
181
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2011
Platform
  1. Windows
  2. MacOS
I am trying to count the number of cells in the range that the user has currently selected. Generally, I know how to do this with the following code:

VBA Code:
Dim TheCount As Integer
TheCount = Selection.Rows.count * Selection.Columns.count

However, if there are any merged cells in the selected area, I need it to count the merged cell as only one cell. Unfortunately, the above code doesn't do that. I've tried coming up with other ways to do it, but nothing has worked. I'm stumped as to how to accomplish this. Anyone have any ideas?
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

mcomp72

Board Regular
Joined
Aug 14, 2016
Messages
181
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2011
Platform
  1. Windows
  2. MacOS
I kept plugging away at it, and figured it out.

VBA Code:
Function CountCells_MergedCountAsOne() As Integer

Dim TheCount As Integer
Dim Cell As Range
Dim MergeAddress As String
Dim MergeAddress_Prev As String

For Each Cell In Selection

    If Cell.MergeCells = False Then
        TheCount = TheCount + 1
    Else
        MergeAddress = Cell.MergeArea.Address
        If MergeAddress <> MergeAddress_Prev Then TheCount = TheCount + 1
        MergeAddress_Prev = MergeAddress
    End If

Next

Set Cell = Nothing

CountCells_MergedCountAsOne = TheCount

End Function
 
Solution

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
346
Office Version
  1. 365
Platform
  1. Windows
Your code in #2 doesn't work properly for merged cells made up of 3 or more cells.
Try this one:
VBA Code:
Function CountSpecial(cntRange As Range) As Long
    Dim rng As Range, dt As Object, cntMerged As Long, cntUnmerged As Long
    On Error GoTo 0
    Set dt = CreateObject("Scripting.Dictionary")
    For Each rng In cntRange
        If rng.MergeCells Then
            TempAddress = rng.MergeArea.Address
            dt(TempAddress) = ""
        Else
            cntUnmerged = cntUnmerged + 1
        End If
    Next
    cntMerged = dt.Count
    CountSpecial = cntMerged + cntUnmerged
    Set dt = Nothing
End Function

Sub CountSpecialTest()
    Debug.Print CountSpecial(Selection)
End Sub
 
Last edited:

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,979
Office Version
  1. 2016
Platform
  1. Windows
Here is a more compact way to write kanadaaa's function...
VBA Code:
Function CountSpecial(Rng As Range) As Long
  Dim Cell As Range
  With CreateObject("Scripting.Dictionary")
    For Each Cell In Rng
      .Item(Cell.MergeArea.Address(0, 0)) = 1
    Next
    CountSpecial = .Count
  End With
End Function
 

mcomp72

Board Regular
Joined
Aug 14, 2016
Messages
181
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2011
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

kanadaaa, I'm not sure what you mean. I just did a test, and it worked fine for me. I created a video of the test, so you can see what I mean. Can you explain how it isn't working for you?

 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,979
Office Version
  1. 2016
Platform
  1. Windows
kanadaaa, I'm not sure what you mean. I just did a test, and it worked fine for me.
Your code appears to work correctly for me when I test it as well. Just wondering though, did you see the function I posted in Message #4? It also works correctly and is half the size of your function.
 

mcomp72

Board Regular
Joined
Aug 14, 2016
Messages
181
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2011
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Your code appears to work correctly for me when I test it as well. Just wondering though, did you see the function I posted in Message #4? It also works correctly and is half the size of your function.
I did. Thank you for that. I haven't switched over to it yet because the workbook I am working on is used primarily on Excel for Mac, and I'm not sure if the CreateObject("Scripting.Dictionary") line will work on Mac. Sometimes creating certain objects like that doesn't work properly on Excel for Mac. When I get a chance, I'll fire up my Mac and test it.
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,979
Office Version
  1. 2016
Platform
  1. Windows
I don't have a Mac so I cannot test it, but my guess is anything creating a "Scripting" object won't work on a Mac. Did you mention that your code needed to work on a Mac (not sure I remember you doing that)?
 

mcomp72

Board Regular
Joined
Aug 14, 2016
Messages
181
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2011
Platform
  1. Windows
  2. MacOS
I don't have a Mac so I cannot test it, but my guess is anything creating a "Scripting" object won't work on a Mac. Did you mention that your code needed to work on a Mac (not sure I remember you doing that)?
I didn't. It slipped my mind when I was writing the original post. I will try to remember to mention it in the future.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,729
Office Version
  1. 365
Platform
  1. Windows
@mcomp72
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)
 

Watch MrExcel Video

Forum statistics

Threads
1,129,931
Messages
5,639,064
Members
417,067
Latest member
rohitbabshet

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top