Sub MergeHeadTest2()
Dim mas() As Long
Dim sel As Range
Dim cl As Range
Dim r, c, i As Long
Set sel = Selection
sel.UnMerge
r = 1
c = 1
i = 1
For c = 1 To sel.Columns.Count
    If sel.Cells(r, c).Value <> "" Then
        If c - i = 1 Then
            Range(sel.Cells(r, i), sel.Cells(sel.Rows.Count, i)).Merge
            i = i + 1
        ElseIf c - i > 1 Then
            Range(sel.Cells(r, i), sel.Cells(r, c - 1)).Merge
        End If
    End If
Next c
End Sub

Sub MergeHeadTest()
'Объединение ячеек в заголовке
Dim i As Integer
Dim j As Integer
Dim g As Range
Dim mas()
Set g = Selection
    With g
        For i = 1 To .Columns.Count
            If .Cells(1, i).Value <> "" Then
                j = j + 1
                ReDim Preserve mas(1 To j)
                mas(j) = i
            End If
        Next i
        If mas(UBound(mas)) <> .Columns.Count Then
            j = j + 1
            ReDim Preserve mas(1 To j)
            mas(j) = .Columns.Count
        End If
        For i = LBound(mas) To UBound(mas)
            If i = UBound(mas) Then
                Range(.Cells(1, mas(i)), .Cells(1, mas(i))).Merge
            Else
                Range(.Cells(1, mas(i)), .Cells(1, mas(i + 1) - 1)).Merge
            End If
        Next i
        If .Rows.Count > 1 Then
            For i = LBound(mas) To UBound(mas)
                If i = UBound(mas) Then
                    Range(.Cells(1, mas(i)), .Cells(1, mas(i))).Merge
                Else
                    Range(.Cells(1, mas(i)), .Cells(1, mas(i + 1) - 1)).Merge
                End If
            Next i
        End If
    End With

End Sub

Sub Test()
Dim rng as Range
'Выделяем текущую область
Set rng = Activecell.CurrentRegion
rng.Select
End Sub