Try this code (not fully tested)

HTH
--
AP

'--------------------
Sub CountBlocks()
Dim rAllBlocks As Range
Dim rCell As Range
Dim strFirstFound As String

Set rCell = Cells.Find( _
   what:="*", _
   after:=ActiveCell, _
   LookIn:=xlFormulas, _
   searchorder:=xlByRows)
If rCell Is Nothing Then
   MsgBox "Empty Worksheet"
   Exit Sub
End If
strFirstFound = rCell.Address
Do
   If rAllBlocks Is Nothing Then
       Set rAllBlocks = rCell.CurrentRegion
   Else
       If Intersect(rCell, rAllBlocks) Is Nothing Then
           Set rAllBlocks = Union(rAllBlocks, rCell.CurrentRegion)
       End If
   End If
   Set rCell = Cells.FindNext(after:=rCell)
Loop Until rCell.Address = strFirstFound
MsgBox rAllBlocks.Areas.Count
End Sub
'-----------------