Объединение ячеек при вставке в разных диапазонах

Sub qq()
    Dim i As Integer, x As Range: Set x = [A1]
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If x.Cells(1, 1) = Cells(i, 1) Then
            Set x = Union(x, Cells(i, 1)): x.Merge
        Else: Set x = Cells(i, 1)
        End If
    Next
End Sub

Application.DisplayAlerts = False
If (Cells(1, 1).Value And Cells(2, 1).Value And Cells(3, 1).Value) = 1 Then
    Range(Cells(1, 1), Cells(3, 1)).MergeCells = True
End If
Application.DisplayAlerts = True

Sub mMergeCells()
'Будем считать, что данные в ст. "А" уже _
       отсортированые.
Dim stRow&, endRow&, mStr$, i&, j&
    For i = 1 To (ActiveSheet.UsedRange.Row - 1 + _
                        ActiveSheet.UsedRange.Rows.Count)
        stRow = 0: endRow = 0
        If Cells(i, 1).Value = Cells(i + 1, 1).Value Then stRow = i
        mStr = Cells(i, 1).Value
        Do
            If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
                endRow = i + 1
            End If
            i = i + 1
        Loop Until Cells(i, 1).Value <> mStr
        Application.DisplayAlerts = False
            If stRow > 0 And endRow > 0 Then
                With Range(Cells(stRow, 1), Cells(endRow, 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                    i = endRow + 1
                End With
            End If
        Application.DisplayAlerts = True
        i = endRow
    Next 'i
End Sub

If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
   stRow = i
    mStr = Cells(i, 1).Value
End if

      For j=Lbound(arrColumn) to Ubound(arrColumn) ' перебор по очереди столбцов
        For i = 1 To (ActiveSheet.UsedRange.Row - 1 + _
                        ActiveSheet.UsedRange.Rows.Count) ' перебор очередного столбца по рядам
          '!!! дальше без изменений....
          '----------------------------
          '----------------------------
        next i
     next j

Sub mMergeCells()
'Будем считать, что данные в ст. "А" уже _
       отсортированые.
Dim arrColumn()
Dim stRow&, endRow&, mStr$, i&, j&
arrColumnn=Array(a,b,....,n) ' Здесь замените буквы реальными номерами
For j=lbound(arrColumn) to ubound(arrColumn)
    For i = 1 To (ActiveSheet.UsedRange.Row - 1 + _
                        ActiveSheet.UsedRange.Rows.Count)
        stRow = 0: endRow = 0
        If Cells(i, j).Value = Cells(i + 1, j).Value Then 
             stRow = i
             mStr = Cells(i, j).Value
        End if
        Do
            If Cells(i, j).Value = Cells(i + 1, j).Value Then
                endRow = i + 1
            End If
            i = i + 1
        Loop Until Cells(i, 1).Value <> mStr
        Application.DisplayAlerts = False
            If stRow > 0 And endRow > 0 Then
                With Range(Cells(stRow, j), Cells(endRow, j))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                    i = endRow + 1
                End With
            End If
        Application.DisplayAlerts = True
        i = endRow
    Next 'i
End Sub

Sub mMergeCells()
'Будем считать, что данные в ст. "А" уже _
       отсортированые.
Dim arrColumn()
Dim stRow&, endRow&, mStr$, i&, j&
arrColumnn=Array(a,b,....,n) ' Здесь замените буквы реальными номерами
For j=lbound(arrColumn) to ubound(arrColumn)
    For i = 1 To (ActiveSheet.UsedRange.Row - 1 + _
                        ActiveSheet.UsedRange.Rows.Count)
        stRow = 0: endRow = 0
        If Cells(i, arrColumn(j)).Value = Cells(i + 1, arrColumn(j)).Value Then 
             stRow = i
             mStr = Cells(i, arrColumn(j)).Value
        End if
        Do
            If Cells(i, arrColumn(j)).Value = Cells(i + 1, arrColumn(j)).Value Then
                endRow = i + 1
            End If
            i = i + 1
        Loop Until Cells(i, arrColumn(j)).Value <> mStr
        Application.DisplayAlerts = False
            If stRow > 0 And endRow > 0 Then
                With Range(Cells(stRow, arrColumn(j)), Cells(endRow, arrColumn(j)))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                    i = endRow + 1
                End With
            End If
        Application.DisplayAlerts = True
        i = endRow
    Next 'i
Next j
End Sub