Sub ertert()
Dim r As Range, rng As Range, adr$, rw&, cl&

rw = Application.InputBox(Prompt:="Строк в об. ячейке:", Default:=8, Type:=1)
cl = Application.InputBox(Prompt:="Столбцов в об. ячейке:", Default:=1, Type:=1)
''or
'rw = Range("A1").Value
'cl = Range("B1").Value
If rw * cl = 0 Then Exit Sub

Set rng = Range("A1")
For Each r In ActiveSheet.UsedRange.Cells
    If r.MergeCells Then
        With r.MergeArea
            If (.Rows.Count = rw) * (.Columns.Count = cl) Then
                If InStr(adr, .Address) = 0 Then Set rng = Union(rng, r.MergeArea)
            End If
        End With
    End If
Next r
'Range("A2").Value = rng.Address(0, 0)
If rng.Count > 2 Then rng.Select
End Sub

Sub ertert()
Dim r As Range, rng As Range, adr$, rw&, cl&
Dim tm!
rw = Application.InputBox(Prompt:="Строк в об. ячейке:", Default:=8, Type:=1)
cl = Application.InputBox(Prompt:="Столбцов в об. ячейке:", Default:=1, Type:=1)
''or
'rw = Range("A1").Value
'cl = Range("B1").Value
If rw * cl = 0 Then Exit Sub
Application.ScreenUpdating = False
tm = Timer
Set rng = Range("A1")
For Each r In ActiveSheet.UsedRange.Cells
    If r.MergeCells Then
        With r.MergeArea
            If (.Rows.Count = rw) * (.Columns.Count = cl) Then
                If InStr(adr, .Address) = 0 Then Set rng = Union(rng, r.MergeArea): adr = adr & "," & .Address
            End If
        End With
    End If
Next r
'Range("A2").Value = rng.Address(0, 0)
If rng.Count > 2 Then rng.Select
Application.ScreenUpdating = True
MsgBox Timer - tm
End Sub

Sub ertert3()
    Dim r As Range, usdr As Range, rng As Range, arr, rw&, cl&
    Dim odic As Object, i As Long, j As Long, addr As String, tm!

    rw = Application.InputBox(Prompt:="Строк в об. ячейке:", Default:=8, Type:=1)
    cl = Application.InputBox(Prompt:="Столбцов в об. ячейке:", Default:=1, Type:=1)
    
    If rw * cl = 0 Then Exit Sub
    Application.ScreenUpdating = False
    tm = Timer

    Set odic = CreateObject("Scripting.Dictionary")
       
    Set usdr = ActiveSheet.UsedRange
    
    For i = 1 To usdr.Rows.Count Step rw
        For j = 1 To usdr.Columns.Count Step cl
            With usdr.Cells(i, j)
                If .MergeCells Then
                    If .MergeArea.Rows.Count = rw And .MergeArea.Columns.Count = cl Then
                        addr = .MergeArea.Address(False, False)
                        If Not odic.Exists(addr) Then odic.Add addr, addr
                    End If
                End If
            End With
        Next j
    Next i
    
    arr = odic.Keys
    Set rng = Range(arr(LBound(arr)))
    For i = LBound(arr) + 1 To UBound(arr)
        Set rng = Union(rng, Range(arr(i)))
    Next i
    
    If rng.Count > 2 Then rng.Select
    Application.ScreenUpdating = True
    Debug.Print Timer - tm
End Sub

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
If Workbooks.Count Then
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
End If
Application.DisplayStatusBar = False
Application.DisplayAlerts = False