We help IT Professionals succeed at work.

Count range cells eliminating merge cells

DanBenedek
DanBenedek asked
on
I have created a method to count the number of cells in a range taking into consideration that merged cell are counted as one cell.

Here is the method

private static int getRangeCount(Range Target)
{
      if (Target == null)
            return 0;
      if (Target.Cells == null)
            return 0;
      if (Target.Cells.Count <= 1)
            return Target.Cells.Count;
      int count = 0;
      foreach (Range cell in Target)
      {
            if (cell.MergeCells != null && cell.MergeCells is bool && (bool)cell.MergeCells)
            {
                  Range rng = (Range)cell.MergeArea[1, 1];
                  if (!Microsoft.Office.Tools.Excel.ExcelLocale1033Proxy.ReferenceEquals(cell, rng))
                  {
                        string str1 = WorkbookUtils.GetAddress(cell, XlReferenceStyle.xlA1);
                        string str2 = WorkbookUtils.GetAddress(rng, XlReferenceStyle.xlA1);
                        if (str1 == str2)
                              count++;
                  }
            }
            else
                  count++;
      }
      return count;
}
My problem now is that a user is using this method on a range with 8448 cells. Because the target is so big the method takes a very very very long time.

Is there a way to improve the above code?

Comment
Watch Question

Commented:
Here is a simple VBA routine that will count the cells in the selected range.  Only counting merged areas as 1.  Works pretty quick on large ranges...
Sub CountSelectedCells()
    Dim c As Range, Merged As Range
    For Each c In Selection
        If c.MergeCells Then
            If Merged Is Nothing Then
                Set Merged = c
            Else
                Set Merged = Union(c, Merged)
            End If
        Else: x = x + 1: End If
    Next
    If Not Merged Is Nothing Then y = Merged.Areas.Count
    MsgBox x + y
End Sub

Open in new window

Author

Commented:
Yes it's working faster than the method i had but still it takes a long time.

Is there an event faster method?
Top Expert 2011
Commented:
This has taken a lot of effort but I think I have it sussed, i've tried it on a full sheet with two merge areas and it is all but instantaneous:

To call the function pass it the required range:

msgbox lngcells(activesheet.cells)
returns for a blank sheet: 16777216

msgbox lngcells(activesheet.cells)
returns for a two merge area sheet: 16777210

msgbox lngcells(activesheet.range("a1:F10"))
returns for a two merge area sheet: 54

Chris
Function lngCells(testrange As Range) As Long
Dim mergeRange As Range
'Dim testrange As Range
Dim thisAddy As String
'Dim lngCells As Long

    Application.ScreenUpdating = False
'    Set testrange = Application.Selection
    lngCells = lngCells + testrange.Cells.Count
    Set mergeRange = Nothing
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
        If Not mergeRange Is Nothing Then mergeRange.Activate
    If Not mergeRange Is Nothing Then
        thisAddy = mergeRange.Address
        Do While mergeRange.CurrentRegion.Cells.Count > 1
            lngCells = lngCells + 1 - mergeRange.CurrentRegion.Cells.Count
            Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True)
            If Not mergeRange Is Nothing Then mergeRange.Activate
            If mergeRange.Address = thisAddy Then Exit Do
        Loop
    End If
    Debug.Print lngCells
    Application.ScreenUpdating = True
    
End Function

Open in new window

Commented:
Nice job Chris.  

Note that Excel 2007 is 1048576x16384 which will overflow full sheet selection.  I tried changing to Double and Variant...both still overflowed.

But I doubt thats a legitimate concern, as its unlikly that the full sheet would be used.
Top Expert 2011

Commented:
harr22

Excel 2007 etc, good observation, I have modified as below to account for that and tested on 2003/2007 looks better now.

Chris
Function lngCells(testrange As Range) As Variant
Dim mergeRange As Range
Dim thisAddy As String

    Application.screenupdating = False
    If Application.Version >= 12# Then
        lngCells = testrange.Cells.CountLarge
    Else
        lngCells = testrange.Cells.Count
    End If
    Set mergeRange = Nothing
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
        If Not mergeRange Is Nothing Then mergeRange.Activate
    If Not mergeRange Is Nothing Then
        thisAddy = mergeRange.Address
        Do While mergeRange.CurrentRegion.Cells.Count > 1
            lngCells = lngCells + 1 - mergeRange.CurrentRegion.Cells.Count
            Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True)
            If Not mergeRange Is Nothing Then mergeRange.Activate
            If mergeRange.Address = thisAddy Then Exit Do
        Loop
    End If
    Application.screenupdating = True
    
End Function

Open in new window

Author

Commented:
@ Chris
Sorry for the late response
I tried to use you're code but it doesn't work correctly. For some reasons the CurrentRegions returns ranges that have absolutly no connection with the merge cells.
But it does work faster than the other methods i had.

@ harr22
It seems that you're code doesn't return the correct result. I have 5 merge ranges of 2 cells each and when i use you're method instead of subtracting only 5, it subtracts 7.
Top Expert 2011

Commented:
Can you provide an example and details - I have tested it with no problem across a number of scenarios so I need more data to work with, including excel version.

Chris

Author

Commented:
I have uploaded a copy of the workbook with witch i have to test. It already has the function in it.
For me the count it's 8035 when it should be 8187.

The workbook is an excel 2003 but i need to tested on both versions of office 2003 and 2007.

Also what i have noticed is that if i delete all the content of the cells then the function returns the correct result 8187.
CountRange.xls
Commented:
How about this
Sub CountCells()
    Dim c As Range, Merged As String
    Dim SearchRange As Range, Startcell As Range
    Set SearchRange = Range("Print_Area")
    Set Startcell = Selection
Application.ScreenUpdating = False
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    On Error GoTo Err
    Do Until InStr(2, Merged, ActiveCell.MergeArea.Address) <> 0
        SearchRange.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
        Merged = ActiveCell.MergeArea.Address & Merged
        x = x + 1
        y = y + ActiveCell.MergeArea.Count
        Debug.Print ActiveCell.MergeArea.Address
    Loop
Err:
    If Err.Number = 0 Then
        MsgBox SearchRange.Count - y + ActiveCell.MergeArea.Count + x - 1
    Else
        MsgBox SearchRange.Count
    End If
    Startcell.Select
    Application.ScreenUpdating = False
End Sub

Open in new window

Commented:
whoops...Line 29 shold be
   Application.ScreenUpdating = True
Top Expert 2011

Commented:
harr22:

I was thinking move the cursor right to get the next column and then back and down to get the next row, and doing it that way but given you get the right answer your adaption must work so i'll leave it as is.

Chris

Author

Commented:
I'm sorry but the code it's still not good.

The Print_Area was just an example were the previouse code did not work.
What i need is a method that will work for ANY range given not only for a specific range.

I have tried the above code for the range B2:D4 and it returned 9 instead of 6
Top Expert 2011

Commented:
I've modified my original then as per my thoughts, both the examples work fine - see how it looks.

Chris
Function lngCells(testrange As Range) As Variant
Dim mergeRange As Range
Dim thisAddy As String
Dim rw As Long
Dim col As Integer

    Application.ScreenUpdating = False
    If Application.Version >= 12# Then
        lngCells = testrange.Cells.CountLarge
    Else
        lngCells = testrange.Cells.Count
    End If
    Set mergeRange = Nothing
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
        If Not mergeRange Is Nothing Then mergeRange.Activate
    If Not mergeRange Is Nothing Then
        thisAddy = mergeRange.Address
        Do While mergeRange.CurrentRegion.Cells.Count > 1
            col = mergeRange.Offset(0, 1).Column - 1
            rw = mergeRange.Offset(1, 0).Row - 1
            lngCells = lngCells + 1 - Range(mergeRange.Address & ":" & mergeRange.Parent.Cells(rw, col).Address).Cells.Count
            Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True)
            If Not mergeRange Is Nothing Then mergeRange.Activate
            If mergeRange.Address = thisAddy Then Exit Do
        Loop
    End If
    Application.ScreenUpdating = True
    
End Function

Open in new window

Commented:
You can change the Range in Row 4 to anything you want.  I used your example.  Changing it to B2:D4 I get "6"

you could do this and it will count whatever is highlighted

Set SearchRange = Selection
Sub CountCells()
    Dim c As Range, Merged As String
    Dim SearchRange As Range, Startcell As Range
    Set SearchRange = Range("B2:D4")
    Set Startcell = Selection
Application.ScreenUpdating = False
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    On Error GoTo Err
    Do Until InStr(2, Merged, ActiveCell.MergeArea.Address) <> 0
        SearchRange.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
        Merged = ActiveCell.MergeArea.Address & Merged
        x = x + 1
        y = y + ActiveCell.MergeArea.Count
    Loop
Err:
    If Err.Number = 0 Then
        MsgBox SearchRange.Count - y + ActiveCell.MergeArea.Count + x - 1
    Else
        MsgBox SearchRange.Count
    End If
    Startcell.Select
    Application.ScreenUpdating = True
End Sub

Open in new window

Author

Commented:
No if i use you're code like i said before it returns 9.

The problem is that you base you're code on ActiveCell (witch it's not what i want but that is not a problem for me). I have changed to use the first cell in the range. (Or in you're case you have to activate/select the SearchRange before line 13)
Top Expert 2011

Commented:
Did you try my update?

Chris

Author

Commented:
Yes but i found an interesting bug to it.

If you use you're code for C2:C3 it returns 0 cells.
Top Expert 2011

Commented:
Just tried it with C":C£ and it returns 2 ... I have run it on a sheet without mefged cells and the sheet 4 with merges ... both say the same!

Chris
Top Expert 2011

Commented:
I have been testing in 2007, when it returned 0 what were you using?

Chris

Commented:
@Dan
Not sure why its not working for you.  Works perfect for me with your sample sheet and anything else I test it on.  The active cell portion is only because its using the find method to jump to the merged areas...then getting the whole merged area of that active cell...so it doesnt double count merged areas.

Anyway, sounds like Chirs is on it...hopefully he can get you a solution that works.

Author

Commented:
Harr

Have you tried to select anywere else except the range you calculate? For example if you have the Active cell H4 and you tried to calculate for range B2:D4 it will return 9. That why i told you to activate the range that is calculated.
Top Expert 2011

Commented:
You didn't answer the question re the filure report so i've found a 2003 PC and tested there myself, it still returns 2 for C2:C3 both in your test sheet and in a blank one so again can you advise how/when you get the failure you reported?

Chris
Top Expert 2011

Commented:
I have in fact managed to reproduce the failure and it seems unavoidable.

Basically with columns * 2 merged if you select a range that only includes one of the columnhs there is no way for the code to know this.  i.e.
If you select  C:E in a row it will work because it covers the columns in the merge.
If you select C:C then the code when running has no way to figure that out as it has no point of reference and therefore returns an erroneous figure.

There are therefore limits to what can be done and that observation hits the limit

Chris

Author

Commented:
I have given chris_bottomley the more point because he was the first to come up with a solution, and to harr22 only some points because he came up with the solution based on the one chris_bottomley suggested.
Top Expert 2011

Commented:
I appreciate my earlier statement and the fact that the question is closed, (albeit a B) but it has been 'bugging' me therefore how about the following rethink:

Chris
Sub test()
MsgBox "Print Area should be 8187 :> " & lngCells(Range("Print_Area"))
MsgBox "B2:D4 should be 6 :> " & lngCells(Range("B2:D4"))
MsgBox "C2:C3 should be 2 :> " & lngCells(Range("C2:C3"))

End Sub

Function lngCells(testrange As Range) As Variant
Dim mergeRange As Range
Dim startRange As Range
Dim thisAddy As String
Dim mergeRows As Long
Dim mergeColumns As Integer

    Set startRange = ActiveCell
    Application.ScreenUpdating = False
    If Application.Version >= 12# Then
        lngCells = testrange.Cells.CountLarge
    Else
        lngCells = testrange.Cells.Count
    End If
    Set mergeRange = Nothing
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    On Error Resume Next
    testrange.Activate
    Set mergeRange = testrange.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
    On Error GoTo 0
    If Not mergeRange Is Nothing Then
        Do While mergeRange.Address <> thisAddy
            If thisAddy = "" Then thisAddy = mergeRange.Address
            If testrange.Columns(testrange.Columns.Count).Column <= mergeRange.Columns(mergeRange.Columns.Count).Column Then
                mergeColumns = Range(mergeRange.Cells(1), mergeRange.Cells(mergeRange.Cells.Count).Offset(0, testrange.Columns(testrange.Columns.Count).Column - mergeRange.Columns(mergeRange.Columns.Count).Column)).Columns.Count
            Else
                mergeColumns = mergeRange.MergeArea.Columns.Count
            End If
            mergeRows = mergeRange.MergeArea.Rows.Count
            If mergeRows > mergeRange.Rows.Count Then mergeRows = mergeRange.Rows.Count
            lngCells = lngCells - (mergeRows * mergeColumns) + 1
            Set mergeRange = testrange.Cells.Find(What:="", After:=mergeRange, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True)
            If Not mergeRange Is Nothing Then mergeRange.Activate
        Loop
    End If
    startRange.Select
    Application.ScreenUpdating = True
    
End Function

Open in new window

Commented:
Also realizing this is closed and also 'bugging me'

@Dan
<Harr - Have you tried to select anywere else except the range you calculate? For example if you have the Active cell H4 and you tried to calculate for range B2:D4 it will return 9. That why i told you to activate the range that is calculated.>

I see...sorry I missed that.  easily resolved by activating the desired range before counting.  Modified below

HTH - Travis
Sub CountCells()
    Dim c As Range, Merged As String
    Dim SearchRange As Range, Startcell As Range
    Set SearchRange = Range("B2:D4")
    Set Startcell = Selection
Application.ScreenUpdating = False
    SearchRange.Activate
    With Application.FindFormat
        .WrapText = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    On Error GoTo Err
    Do Until InStr(2, Merged, ActiveCell.MergeArea.Address) <> 0
        SearchRange.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
        Merged = ActiveCell.MergeArea.Address & Merged
        x = x + 1
        y = y + ActiveCell.MergeArea.Count
    Loop
Err:
    If Err.Number = 0 Then
        MsgBox SearchRange.Count - y + ActiveCell.MergeArea.Count + x - 1
    Else
        MsgBox SearchRange.Count
    End If
    Startcell.Select
    Application.ScreenUpdating = True
End Sub

Open in new window