Sub Test()
Dim irow As Range, icel As Range, mergeVal As String
Application.DisplayAlerts = False
For Each irow In Selection.Rows
For Each icel In irow.Cells
If icel.Value <> "" Then mergeVal = mergeVal
Next icel
If mergeVal <> "" Then irow(1).Value = Left(mergeVal, Len(mergeVal) - 1)
mergeVal = ""
irow.Merge
Next irow
Application.DisplayAlerts = True
End Sub

Option Explicit
Sub iConcatenate()
Dim i As Long
Dim iLastRow As Long
Dim j As Long
Dim k As Long
Dim j_col As Long
Application.DisplayAlerts = False
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 5 To iLastRow
      For j = 14 To 5 Step -1
        If Cells(i, j) <> "" Then
          j_col = Cells(i, j).Column
          If j_col > 5 Then
            For k = j_col To 5 Step -1
              If IsEmpty(Cells(i, k)) Or k <= 5 Then
                Range(Cells(i, k), Cells(i, j_col - 1)).MergeCells = True
                Exit For
              End If
            Next
          End If
        End If
      Next
    Next
Application.DisplayAlerts = True
End Sub

Sub Макрос1()
Dim n As Integer, m As Integer, rng As Range
Application.DisplayAlerts = False
arr1 = Range("A1:N" & Cells(Rows.Count, "C").End(xlUp).Row)
    For n = 5 To UBound(arr1)
        For m = 5 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub

Sub Макрос1()
Dim n As Integer, m As Integer, lr As Integer, lc As Integer, rng As Range
Application.DisplayAlerts = False
Set myCell = Range("A1:Z100").Find("Пары")
lr = Cells(Rows.Count, myCell.Column).End(xlUp).Row
lc = Cells(myCell.Row, Columns.Count).End(xlToLeft).Column
arr1 = Range(Cells(1, 1), Cells(lr, lc))
    For n = myCell.Row + 1 To UBound(arr1)
        For m = myCell.Column + 2 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub