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

[mcomp72]

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:

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?

 

[mcomp72]

I kept plugging away at it, and figured it out.

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

 

[kanadaaa]

Your code in #2 doesn't work properly for merged cells made up of 3 or more cells.
Try this one:

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

 

[Rick Rothstein]

Here is a more compact way to write kanadaaa's function...

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]

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]

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]

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]

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]

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]

@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’)