Overlapping areas in same range, duplicate cells

Question

Consider the following code:

Dim rng As Range
Dim rngCell As Range

Set rng = ActiveSheet.Cells(2, 2).Resize(3, 3)
Set rng = Union(rng, ActiveSheet.Cells(3, 3).Resize(3, 3))
Set rng = Union(rng, ActiveSheet.Cells(4, 4).Resize(3, 3))

'Shows 27, should be 19
MsgBox rng.Cells.Count

rng.ClearContents
For Each rngCell In rng.Cells
    rngCell = rngCell + 1
Next rngCell

The result is:

Basically the code produces one range variable which holds 3 overlapping areas. When iterating over the cells with For Each, some cells are visited more than once. Also, Cells.Count shows a higher number than the actual number of (unique) cells in the range.

How do I flatten/collapse these 3 areas so that there is no overlapping?

Answer 1

• rng.Address is $B$2:$D$4,$C$3:$E$5,$D$4:$F$6. Union creates a range cover two ranges, but it doesn't remove duplicated cells.
• mergeRng.Address is $B$2:$D$4,$E$3:$E$4,$F$4,$C$5:$F$5,$D$6:$F$6. The mergeRng is formed by repeatedly adding individual cells through the Union operation.

Option Explicit

Sub Demo()
    Dim rng As Range
    Dim rngCell As Range
    Dim mergeRng As Range
    Set rng = ActiveSheet.Cells(2, 2).Resize(3, 3)
    Set rng = Union(rng, ActiveSheet.Cells(3, 3).Resize(3, 3))
    Set rng = Union(rng, ActiveSheet.Cells(4, 4).Resize(3, 3))
    
    'Shows 27, should be 19
    Debug.Print rng.Cells.Count
    Debug.Print rng.Address
    
    For Each rngCell In rng.Cells
        If mergeRng Is Nothing Then
            Set mergeRng = rngCell
        Else
            Set mergeRng = Union(mergeRng, rngCell)
        End If
    Next rngCell
    Debug.Print mergeRng.Cells.Count
    Debug.Print mergeRng.Address
    mergeRng.ClearContents
    For Each rngCell In mergeRng.Cells
        rngCell = rngCell + 1
    Next rngCell
End Sub

Answer 2

you could use SpecialCells() method of Range object

Sub NoOverlap()
    Dim rng As Range
    
    With ActiveSheet
        Set rng = .Cells(2, 2).Resize(3, 3)
        Set rng = Union(rng, .Cells(3, 3).Resize(3, 3))
        Set rng = Union(rng, .Cells(4, 4).Resize(3, 3))
    End With
    
    With rng
        .ClearContents
        Set rng = .SpecialCells(xlCellTypeBlanks)
    End With
    MsgBox rng.Cells.Count ' it shows 19
    
    Dim rngCell As Range
    For Each rngCell In rng.Cells
        rngCell = rngCell + 1
    Next
End Sub