Find Merged Cells VBA

[Admin]

Hi All,

Here is a function to find merged cells. Hope this would find useful

Function FindMergedCells(ByRef RangeToSearch As Range) As Range
        
    'Krishnakumar @ ExcelFox.com
    Dim dic     As Object
    Dim r       As Long
    Dim c       As Long
    Dim k, i    As Long
    Dim UB1     As Long
    Dim UB2     As Long
    
    UB1 = RangeToSearch.Rows.Count
    UB2 = RangeToSearch.Columns.Count
    
    Set dic = CreateObject("scripting.dictionary")
    
    For r = 1 To UB1
        For c = 1 To UB2
            If RangeToSearch.Cells(r, c).MergeArea.Cells.Count > 1 Then
                dic.Item(RangeToSearch.Cells(r, c).MergeArea.Cells.Address(0, 0)) = Empty
            End If
        Next
    Next
    
    If dic.Count Then
        k = dic.keys
        For i = LBound(k) To UBound(k)
            If FindMergedCells Is Nothing Then
                Set FindMergedCells = RangeToSearch.Range(CStr(k(i)))
            Else
                Set FindMergedCells = Union(FindMergedCells, RangeToSearch.Range(CStr(k(i))))
            End If
        Next
    End If
    
End Function

and call the function like..

Sub kTest()
    
    Dim c As Range
    
    Set c = FindMergedCells(Range("j1:n1000"))
    If Not c Is Nothing Then c.Interior.Color = 65535

End Sub

Enjoy !!