[[20211124222131]]　『同じ値　複数行の結合　VBA』（つん）　ページの最後に飛ぶ

『同じ値　複数行の結合　VBA』（つん）

excelでガントチャートを作成しています。
指定したセルに色付けするところまではできましたが、そのセル内に文字を入れたいと思っています。IF関数を用い、必要セルに文字を返すことはできましたが、すべてのセルに関数が入っているため、文字をすべて表示させることができません。そのため、ネットで調べ、セルを結合させるVBAがあることをしり以下のコードを使用しましたが、単一行のみの動作となるため、手間が生じてます。
複数行の作業となるように改変できたらお願いします。

また、VBAを使用するのであれば、もっと楽にガントチャートができるかもしれませんが、私自身がVBAをよく知りません。
もし、もっと楽な方法があるのであればご教授いただけたら幸いです。

以下　コード

'指定行で同じデータが連続した場合そのセル範囲を結合する
Sub 結合()

    Dim rng As Range
    Dim Row As Long, tgc As Long
    Dim sc As Long, ec As Long
    Dim i, j As Long
    'Application.InputBoxで列を指定できるようにする
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="対象行のセル範囲を選択指定するか" & vbCrLf & _
        "行の先頭セルを選択してください！", Title:="対象セル選択", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    '選択された先頭セルの行と列の番号を取得します
    Row = rng.Row
    sc = rng.Column
    'セル選択状態を判定して最終列を取得します
    If rng.Count = 1 Then
        ec = Cells(Row, Columns.Count).End(xlToLeft).Column '先頭だけ選択の場合
    Else
        ec = sc + rng.Count - 1 '範囲で選択している場合
    End If
    Set rng = Cells(Row, sc)    '先頭セルをRangeオブジェクト変数に代入

    For tgc = sc To ec - 1      '最終列の一つ手前までループ処理
        With Cells(Row, tgc)
            '次のセルとセルの値を比較して同じ間はセル範囲を広げます
            If .Value = .Offset(0, 1).Value Then
                Set rng = Union(rng, .Offset(0, 1))
            Else
             '値が違うセルが出現したら広げていた範囲を結合します
               Application.DisplayAlerts = False
                rng.Merge
                rng.HorizontalAlignment = xlHAlignCenter '横中央
                'rng.VerticalAlignment = xlVAlignCenter   '縦中央
                Application.DisplayAlerts = True
                Set rng = .Offset(0, 1)    '次のセルをRange変数に代入
            End If
        End With
    Next
    '範囲の一番最後が前のセルと同じだった場合の結合処理
    If rng.Count > 1 Then 'Range変数が複数だった場合結合します
        Application.DisplayAlerts = False
        rng.Merge
        rng.HorizontalAlignment = xlHAlignCenter '横中央
        'rng.VerticalAlignment = xlVAlignCenter   '縦中央
        Application.DisplayAlerts = True
    End If
End Sub

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

 >単一行のみの動作となるため、手間が生じてます。
 >複数行の作業となるように改変できたらお願いします。
 Application.InputBoxで選択した先頭セルから下に
 空白セルまで処理を行います。のつもりですが･･･(;^_^A)

 参考に
 Sub 結合2()
    Dim rng As Range
    Dim tgc As Long
    Dim sc As Long, ec As Long

    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="先頭セルを選択して下さい。", Title:="対象セル選択", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    Set rng = rng.Cells(1, 1)                                           '先頭セルをRangeオブジェクト変数に代入
    sc = rng.Column

    Do Until rng.Value = ""                                             '条件が満たされると繰り返し処理を終了
        ec = Cells(rng.Row, Columns.Count).End(xlToLeft).Column         '最終列
        For tgc = sc To ec                                              '最終列までループ処理
            With Cells(rng.Row, tgc)
                '次のセルとセルの値を比較して同じ間はセル範囲を広げます
                If .Value = .Offset(0, 1).Value Then
                    Set rng = Union(rng, .Offset(0, 1))
                Else
                    '値が違うセルが出現したら広げていた範囲を結合します
                    Application.DisplayAlerts = False
                    rng.Merge
                    rng.HorizontalAlignment = xlHAlignCenter            '横中央
                    'rng.VerticalAlignment = xlVAlignCenter             '縦中央
                    Application.DisplayAlerts = True
                    Set rng = .Offset(0, 1)                             '次のセルをRange変数に代入
                End If
            End With
        Next
        Set rng = Cells(rng.Row + 1, sc)                                '次の行の先頭セルをrngに代入
    Loop
    MsgBox "終わり", vbInformation
 End Sub

（ピンク） 2021/11/24(水) 23:27

ありがとうございます。
空白があるとできないんですね。
空白をなくすことで、無事処理できるようになりました。
（つん） 2021/11/26(金) 07:11

 >空白があるとできないんですね。
 Sub 結合3()
    Dim rng As Range
    Dim tgc As Long
    Dim sc As Long, ec As Long, sr As Long, i As Long
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="先頭セルを選択して下さい。", Title:="対象セル選択", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    Set rng = rng.Cells(1, 1)                                               '先頭セルをRangeオブジェクト変数に代入
    sc = rng.Column
    sr = rng.Row
    For i = sr To Cells(Rows.Count, sc).End(xlUp).Row
        If Cells(i, sc).Value <> "" Then
            ec = Cells(i, Columns.Count).End(xlToLeft).Column               '最終列
            For tgc = sc To ec                                              '最終列までループ処理
                With Cells(i, tgc)
                   '次のセルとセルの値を比較して同じ間はセル範囲を広げます
                    If .Value = .Offset(0, 1).Value Then
                      Set rng = Union(rng, .Offset(0, 1))
                    Else
                        '値が違うセルが出現したら広げていた範囲を結合します
                        Application.DisplayAlerts = False
                        If rng.Cells.Count > 1 Then rng.Merge
                        rng.HorizontalAlignment = xlHAlignCenter            '横中央
                        'rng.VerticalAlignment = xlVAlignCenter             '縦中央
                        Application.DisplayAlerts = True
                        Set rng = .Offset(0, 1)                             '次のセルをRange変数に代入
                    End If
                End With
            Next
        End If
        Set rng = Cells(i + 1, sc)                                          '次の行の先頭セルをrngに代入
    Next
    MsgBox "終わり", vbInformation
 End Sub
（ピンク） 2021/11/26(金) 07:49

コメント返信：

[ 一覧(最新更新順) ]

[[20211124222131]] 『同じ値 複数行の結合 VBA』（つん） ページの最後に飛ぶ

[[20211124222131]]　『同じ値　複数行の結合　VBA』（つん）　ページの最後に飛ぶ