[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同じ値 複数行の結合 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
>空白があるとできないんですね。 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.