Excel VBA セル範囲結合時に各セルの値も結合させる方法

'複数の選択セル範囲の結合に各セルの値もマージする
Sub MergeCellsImprove()
    Dim rng As Range, sRng As Range
    Dim txt As String, str As String
    Dim i As Long, ac As Long, col As Long
    
    On Error Resume Next
    Set sRng = Application.InputBox( _
                Prompt:="対象セル範囲を選択指定してください！" _
                , Title:="範囲選択", Type:=8)
    On Error GoTo 0
    If sRng Is Nothing Then Exit Sub
    
    '選択セル範囲毎に処理する。列数が複数ある場合列は別処理にする
    For ac = 1 To sRng.Areas.Count
        txt = "": str = "": i = 0 '変数初期化
        For Each rng In sRng.Areas(ac)
            '選択エリアの最初の列番号
            col = sRng.Areas(ac).Column
            '対象セルの列番号を比較して動作を分ける
            If col < rng.Column Then    '列が2番目以降の場合
                '列が2番目以降の場合の処理（"/"でつなぐ）
                If rng.Text <> "" And rng.Text <> str Then
                    str = rng.Text
                    txt = txt & "/" & str
                End If
            Else
                i = i + 1       'カウンター
                If i = 1 Then   '初回だけ
                    txt = rng.Text
                    str = txt
                Else
                    '前回と同一でない場合だけ処理（改行文字でつなぐ）
                    If rng.Text <> "" And rng.Text <> str Then
                        str = rng.Text
                        txt = txt & vbCrLf & str
                    End If
                End If
            End If
        Next
        Application.DisplayAlerts = False 'アラートを中止
        With sRng.Areas(ac)
            .MergeCells = True  'セル範囲を結合する
            .Value = txt        '値を代入する
            .HorizontalAlignment = xlHAlignCenter '横中央
            .VerticalAlignment = xlVAlignCenter   '縦中央
        End With
        Application.DisplayAlerts = True 'アラート再開
    Next
End Sub

'横方向のマージを行ごとに行うコード
Sub MergeCellsAcross()
    Dim sRng As Range
    
    On Error Resume Next
    Set sRng = Application.InputBox( _
                Prompt:="対象セル範囲を選択指定してください！" _
                , Title:="範囲選択", Type:=8)
    On Error GoTo 0
    If sRng Is Nothing Then Exit Sub
                
    Application.DisplayAlerts = False 'アラートを中止
    With sRng
        .Merge across:=True 'セル範囲を行ごとに結合する
        .HorizontalAlignment = xlHAlignCenter '横中央
        .VerticalAlignment = xlVAlignCenter   '縦中央
    End With
    Application.DisplayAlerts = True 'アラート再開
End Sub