I wrote this macro to insert a row keeping the formatting and, in some cases, automatically merging the inserted rows in Columns A and C. My issue is when the selection is on a merged cell this code implements the number of rows that are merged, I only want it to insert 1 row in this circumstance as keep the formatting and merging that I prescribe in this code. Thanks for all your help

Sub insertrow()
Dim i As Long, j As Long
Dim r As Range, lastrow As Long
Dim col As Long, formcol As Long
Dim lastcol As Long, s As Range
Dim q As Long
i = 2          'start row
col = 1        ' column to process
q = 1
Set r = ActiveSheet.UsedRange.Columns(col).Cells
lastrow = r(r.Count).Row + 1
Debug.Print lastrow
Set r = Nothing
Set s = ActiveSheet.UsedRange.Rows(i).Cells
lastcol = s(s.Count).Column
Debug.Print lastcol
Set s = Nothing
Selection.EntireRow.Insert
If Cells(Selection.Row + 1, "A") <> Cells(Selection.Row - 1, "A") And ISMERGED(Cells(Selection.Row + 1, "A")) = False Then
    Range(Cells(Selection.Row + 1, "A"), Cells(Selection.Row, "A")).FillUp
    Range(Cells(Selection.Row + 1, "C"), Cells(Selection.Row, "C")).FillUp
ElseIf Cells(Selection.Row + 1, "A") <> Cells(Selection.Row - 1, "A") And ISMERGED(Cells(Selection.Row + 1, "A")) = True Then
    Cells(Selection.Row, "A") = Cells(Selection.Row + 1, "A")
    Cells(Selection.Row + 1, "A") = ""
    Cells(Selection.Row, "C") = Cells(Selection.Row + 1, "C")
    Cells(Selection.Row + 1, "C") = ""
    Do While q <= 3
    If Cells(Selection.Row + 1, q) = "" Then
        Cells(Selection.Row + 1, q).UnMerge
    End If
    q = q + 2
    Loop
    For q = 1 To 3 Step 2
    For i = 2 To 36
        If Trim(Cells(i, q)) <> "" Then
            If j > 1 Or i = 36 Then
                r.Resize(j, 1).Merge
            End If
        Set r = Cells(i, q)
        j = 1
        ElseIf Not r Is Nothing Then
            j = j + 1
        End If
    Next i
Next q
Else
    Range(Cells(Selection.Row, "A"), Cells(Selection.Row, "A")).FillDown
    Range(Cells(Selection.Row, "C"), Cells(Selection.Row, "C")).FillDown
End If
Do While col <= lastcol
If Cells(i - 1, col).HasFormula = True Then
    Range(Cells(Selection.Row, col), Cells(Selection.Row, col)).FillDown
i = i + 1
End If
i = i + 1
col = col + 1
Loop
End Sub