ベストアンサー

※ ChatGPTを利用し、要約された質問です（原文：条件によってセルの結合を実行）

条件によってセルの結合を実行する方法

2018/10/07 11:11

このQ&Aのポイント

セル結合を行う際に条件を設けることで、特定の階層のみの結合や、階層ごとに条件を設けて結合することが可能です。
同じビジネステーマであっても、一つ上の階層の名称が異なる場合は別々に結合されるように条件を設定することが重要です。
セル結合を実行する際には注意が必要であり、正しい条件を設けることで最適な結果が得られます。

条件によってセルの結合を実行

階層に並んでいるデータがあります。　（1階層）　　　　　（2階層）　　　（3階層）　　　（4階層）　　　（5階層） A1　ビジネステーマ　＞　マーケット　＞　サービス　＞　資料　＞　ナンバー A2　　（セル結合）　（セル結合）　（セル結合）　（セル結合）　（セル結合） A3　　（セル結合）　（セル結合）　（セル結合）　（セル結合）　（セル結合） A4　　（セル結合）　（セル結合）　（セル結合）　（セル結合）　（セル結合） A5　　（セル結合）　（セル結合）　（セル結合）　（セル結合）　（セル結合） A6　ビジネステーマ　＞　　特定　＞　拡張　＞　プロジェクト　＞　見積 A7　　（セル結合）　（セル結合）　（セル結合）　（セル結合）　（セル結合）　・　・　・ A1のビジネステーマとA6のビジネステーマは同じなので、セル結合するようにマクロ実行をしたいです。もし、その条件でマクロを実行するとしたら、問題なのは下記です。 2階層は別々なのに、たまたま3階層の名称が同じであった場合は結合してしまうことです。（1階層）　　　　（2階層）　　　　　　（3階層）エネルギー　　＞　　地銀関連　　＞　　自治体マーケットエネルギー　　＞　　地方　　　　＞　　自治体マーケット間違いエネルギー　　＞　　地銀関連　　＞　　自治体マーケット（セル結合）　＞　　地方　　　　＞　　（セル結合）正解エネルギー　　＞　　地銀関連　　＞　　自治体マーケット（セル結合）　＞　　地方　　　　＞　　自治体マーケット一段上の階層の名称が別々であれば、以下の階層は別々に結合するといった条件はどのようにしたら良いでしょうか？なかなか難しいかと思いますが、いい方法がありましたら教えてください。宜しくお願いします。

73sho
お礼率66% (18/27)

Excel（エクセル）
回答数13
ありがとう数8

みんなの回答 （13）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

watabe007
ベストアンサー率62% (476/760)

2018/10/08 08:55 回答No.11

Sub FinalAnswer() 　　Dim c As Long, r As Long 　　Dim LevelName As String, pLevelName As String 　　Dim 始 As Long, 終 As Long 　　Application.ScreenUpdating = False 　　For c = 1 To 6 '1列から最終列の6列までループ　　　　始 = 2 　　　　LevelName = Cells(2, c).MergeArea.Item(1).Value 　　　　If c = 1 Then 　　　　　　For r = 2 To 23 '2行～最終行の23行までループ　　　　　　　　If Cells(r, c).MergeArea.Item(1).Value <> LevelName Then 　　　　　　　　　　終 = r - 1 　　　　　　　　　　LevelName = Cells(r, c).MergeArea.Item(1).Value 　　　　　　　　　　Application.DisplayAlerts = False 　　　　　　　　　　Range(Cells(始, c), Cells(終, c)).Merge 　　　　　　　　　　Application.DisplayAlerts = True 　　　　　　　　　　始 = r 　　　　　　　　ElseIf r = 23 Then '※23は最終行の数字　　　　　　　　　　終 = r 　　　　　　　　　　Application.DisplayAlerts = False 　　　　　　　　　　Range(Cells(始, c), Cells(終, c)).Merge 　　　　　　　　　　Application.DisplayAlerts = True 　　　　　　　　End If 　　　　　　Next 　　　　Else 　　　　　　pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value 　　　　　　For r = 2 To 23 　　　　　　　　If Cells(r, c).MergeArea.Item(1).Value <> LevelName Or _ 　　　　　　　　　　Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 　　　　　　　　　　終 = r - 1 　　　　　　　　　　Application.DisplayAlerts = False 　　　　　　　　　　Range(Cells(始, c), Cells(終, c)).Merge 　　　　　　　　　　Application.DisplayAlerts = True 　　　　　　　　　　pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value 　　　　　　　　　　LevelName = Cells(r, c).MergeArea.Item(1).Value 　　　　　　　　　　始 = r 　　　　　　　　ElseIf r = 23 Then '※23は最終行の数字　　　　　　　　　　終 = r 　　　　　　　　　　Application.DisplayAlerts = False 　　　　　　　　　　Range(Cells(始, c), Cells(終, c)).Merge 　　　　　　　　　　Application.DisplayAlerts = True 　　　　　　　　End If 　　　　　　Next 　　　　End If 　　Next 　　Application.ScreenUpdating = True End Sub

その他の回答 (12)

watabe007
ベストアンサー率62% (476/760)

2018/10/08 09:47 回答No.13

>マックのエラーの出る原因はこれのようです。 >Range(Cells(始, c), Cells(終, c)).Merge 結合する前に、一旦、解除すればどうなるでしょうか？ Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).UnMerge Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True

質問者

お礼 2018/10/08 10:32

ありがとうございます。結果は変わりませんでした。マックはともかく、ウィンで問題なく動作できましたので、これにで終了させてください。

watabe007
ベストアンサー率62% (476/760)

2018/10/08 09:30 回答No.12

>すみませんが、最後尾は「ここまで」を判断に加えたいのですが。 LastRow-1 で最終行を検出しました。 >上の階層の名称が別なら今の階層の名称が同じでも結合しない、上の階層の名称が変わる、もしくは今の階層の名称が変われば「始」から始まった行から変わる直前の行までを結合します。 Sub FinalAnswer() Dim c As Long, r As Long Dim LevelName As String, pLevelName As String Dim 始 As Long, 終 As Long, LastRow As Long Application.ScreenUpdating = False LastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 For c = 1 To 6 '1列から最終列の6列までループ始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value If c = 1 Then For r = 2 To LastRow If Cells(r, c).MergeArea.Item(1).Value <> LevelName Then 終 = r - 1 LevelName = Cells(r, c).MergeArea.Item(1).Value Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r ElseIf r = LastRow Then 終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True End If Next Else pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value For r = 2 To LastRow If Cells(r, c).MergeArea.Item(1).Value <> LevelName Or _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value 始 = r ElseIf r = LastRow Then 終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True End If Next End If Next Application.ScreenUpdating = True End Sub

質問者

お礼 2018/10/08 10:32

ありがとうございます。おかげさまでうまく動作できました。

watabe007
ベストアンサー率62% (476/760)

2018/10/08 01:11 回答No.10

最後です Sub Test6() Dim c As Long, r As Long Dim LevelName As String, pLevelName As String Dim 始 As Long, 終 As Long Application.ScreenUpdating = False For c = 1 To 6 '1列から最終列の6列までループ始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value If c = 1 Then For r = 2 To 23 '2行～最終行の23行までループ If Cells(r, c).MergeArea.Item(1).Value <> LevelName Then 終 = r - 1 LevelName = Cells(r, c).MergeArea.Item(1).Value Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r ElseIf r = 23 Then '※23は最終行の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 End If Next Else 始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value For r = 2 To 23 If Cells(r, c).MergeArea.Item(1).Value <> LevelName Or _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value 始 = r ElseIf r = 23 Then '※23は最終行の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 End If Next End If Next Application.ScreenUpdating = True End Sub

質問者

お礼 2018/10/08 09:04

ありがとうございます。マックの方はエラーは出ますが、終了ボタンをクリックすると結合がうまく完了しています。エラーメッセージがちょっと残念ですが、ウィンの方は知り合いの人に確認してみましたところ、問題なく、うまく動作できたとのことでした。すみませんが、最後尾は「ここまで」を判断に加えたいのですが。それと、そのコードはどんな流れでしょうか？上の階層の名称が別なら今の階層の名称が同じでも結合しない、といった流れでしょうか？

質問者

補足 2018/10/08 09:06

マックのエラーの出る原因はこれのようです。 Range(Cells(始, c), Cells(終, c)).Merge

watabe007
ベストアンサー率62% (476/760)

2018/10/08 00:28 回答No.9

Sub Test5() Dim c As Long, r As Long Dim LevelName As String, pLevelName As String Dim 始 As Long, 終 As Long Application.ScreenUpdating = False For c = 1 To 6 '1列から最終列の6列までループ始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value If c = 1 Then For r = 2 To 23 '2行～最終行の23行までループ If Cells(r, c).MergeArea.Item(1).Value <> LevelName Then 終 = r - 1 LevelName = Cells(r, c).MergeArea.Item(1).Value Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r ElseIf r = 23 Then '※最終行の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 End If Next Else 始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value For r = 2 To 23 If Cells(r, c).MergeArea.Item(1).Value <> LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value = pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value 始 = r ElseIf r = 23 And (Cells(r, c).MergeArea.Item(1).Value <> LevelName Or _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName) Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 ElseIf r = 23 Then '※最終行の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 ElseIf Cells(r, c).MergeArea.Item(1).Value <> LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value ElseIf Cells(r, c).MergeArea.Item(1).Value = LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value End If Next End If Next Application.ScreenUpdating = True End Sub

watabe007
ベストアンサー率62% (476/760)

2018/10/08 00:03 回答No.8

訂正 >ElseIf r = 23 Then '※最終列の数字 ElseIf r = 23 Then '※23は最終行の数字

watabe007
ベストアンサー率62% (476/760)

2018/10/07 23:59 回答No.7

さてさて、どうでしょうか？ Sub Test4() Dim c As Long, r As Long Dim LevelName As String, pLevelName As String Dim 始 As Long, 終 As Long Application.ScreenUpdating = False For c = 1 To 6 '1列から最終列の6列までループ始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value If c = 1 Then For r = 2 To 23 '2行～最終行の23行までループ If Cells(r, c).MergeArea.Item(1).Value <> LevelName Then 終 = r - 1 LevelName = Cells(r, c).MergeArea.Item(1).Value Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r ElseIf r = 23 Then '※最終列の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 End If Next Else 始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value For r = 2 To 23 If Cells(r, c).MergeArea.Item(1).Value <> LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value = pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value 始 = r ElseIf r = 23 Then '※最終列の数字終 = r Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = 2 ElseIf Cells(r, c).MergeArea.Item(1).Value <> LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value ElseIf Cells(r, c).MergeArea.Item(1).Value = LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value <> pLevelName Then 終 = r - 1 Application.DisplayAlerts = False Range(Cells(始, c), Cells(終, c)).Merge Application.DisplayAlerts = True 始 = r pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value End If Next End If Next Application.ScreenUpdating = True End Sub

watabe007
ベストアンサー率62% (476/760)

2018/10/07 22:37 回答No.6

>Range(Cells(2, 1), Cells(3, 1)).Merge いえ書き換えるのではなく単独で試してもらいたかったのです。 Sub Test() 　　Range(Cells(2, 1), Cells(3, 1)).Merge End Sub 結合セル内で結合してるのですがWin7 Excel2010ではエラーは出ないのですがマックでは出たのですね、う~ん、周りにマックの環境が無いので今のところ対策は？？？です。 On Error Resume Next を入れたら、どの様になりますか？ Sub Test3() 　　Dim c As Long, r As Long 　　Dim LevelName As String, pLevelName As String 　　Dim 始 As Long, 終 As Long 　　On Error Resume Next 　　Application.ScreenUpdating = False

質問者

お礼 2018/10/07 23:15

Sub Test() 　　Range(Cells(2, 1), Cells(3, 1)).Merge End Sub で実行しましたところエラーもなく、結合もなく、何も起こりませんでした。あと、下記のコードも同様に何も変わりませんでした。 Sub Test3() 　　Dim c As Long, r As Long 　　Dim LevelName As String, pLevelName As String 　　Dim 始 As Long, 終 As Long 　　On Error Resume Next 　　Application.ScreenUpdating = False

watabe007
ベストアンサー率62% (476/760)

2018/10/07 20:23 回答No.5

一列目の場合「ビジネステーマ」が続く限り Application.DisplayAlerts = False Range(Cells(2, 1), Cells(3, 1)).Merge Application.DisplayAlerts = True 　　　↓　　　　↓ Application.DisplayAlerts = False Range(Cells(2, 1), Cells(15, 1)).Merge Application.DisplayAlerts = False 15行まで繰り返して処理していますマック、エクセル2011では Application.DisplayAlerts = False Range(Cells(2, 1), Cells(3, 1)).Merge Application.DisplayAlerts = True でエラーは出ますか？こちらは、Win7(64) Excel2010です。

質問者

お礼 2018/10/07 21:59

Range(Cells(2, 1), Cells(3, 1)).Merge に書き換えたところ、エラーがでました。コードを見ましたら、もう一つありましたので、2つとも Range(Cells(2, 1), Cells(3, 1)).Merge に書き換えました。エラーは出なかったのですが、結合する動作はしなかったのでした。

watabe007
ベストアンサー率62% (476/760)

2018/10/07 19:20 回答No.4

こちらでは再現しないです。もしやシートに保護がかかっている事は無いですかエラーが出たコード Range(Cells(始, c), Cells(r, c)).Merge 始、c、r、などにマウスを持って行くと値が出ますが幾ら出ていますか

質問者

お礼 2018/10/07 19:45

「始、c、r、などにマウスを持って行くと値が出ますが幾ら出ていますか」出てないです。マックだからでしょうか？環境はマック、エクセル2011です。

watabe007
ベストアンサー率62% (476/760)

2018/10/07 16:11 回答No.3

修正、第2弾!!(^_^;) Sub Test3() Dim c As Long, r As Long Dim LevelName As String, pLevelName As String Dim 始 As Long, 終 As Long Application.ScreenUpdating = False For c = 1 To 6 '1列から最終列の6列までループ始 = 2 LevelName = Cells(2, c).MergeArea.Item(1).Value If c = 1 Then For r = 2 To 23 '2行～最終行の23行までループ If Cells(r, c).MergeArea.Item(1).Value = LevelName Then LevelName = Cells(r, c).MergeArea.Item(1).Value Application.DisplayAlerts = False Range(Cells(始, c), Cells(r, c)).Merge Application.DisplayAlerts = True Else 始 = r LevelName = Cells(r, c).MergeArea.Item(1).Value End If Next Else 始 = 2 pLevelName = Cells(2, c - 1).MergeArea.Item(1).Value For r = 2 To 23 If Cells(r, c).MergeArea.Item(1).Value = LevelName And _ Cells(r, c - 1).MergeArea.Item(1).Value = pLevelName Then Application.DisplayAlerts = False Range(Cells(始, c), Cells(r, c)).Merge Application.DisplayAlerts = True pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value Else 始 = r pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value LevelName = Cells(r, c).MergeArea.Item(1).Value End If Next End If Next Application.ScreenUpdating = True End Sub

質問者

お礼 2018/10/07 17:50

ありがとうございます。マクロ実行してみましたところエラーが出ました。

条件によってセルの結合を実行する方法

条件によってセルの結合を実行

質問者が選んだベストアンサー

その他の回答 (12)

お礼 2018/10/08 10:32

お礼 2018/10/08 10:32

お礼 2018/10/08 09:04

補足 2018/10/08 09:06

お礼 2018/10/07 23:15

お礼 2018/10/07 21:59

お礼 2018/10/07 19:45

お礼 2018/10/07 17:50

関連するQ&A

セルの結合マクロについて

Excel（セルの結合マクロ）

エクセルのセル～結合セルへのコピーの仕方を教えて

セル結合をマクロで行ないたい（その２）

数字が入力されているセルの結合

エクセル、セル結合について

エクセルのセルの結合について質問です。

VBAでの結合セルのコピー＆ペースト

(VBAにて)列のセルの結合について

Excel マクロ条件によるセルの結合

エクセルで論理式が真の場合、セルの結合

エクセルのマクロで結合セルに値を貼り付けたい

セル結合部の合計額

エクセルで結合セルのコピー

異なるブックを結合した時のセル参照

エクセルで複数セルの文字を一回で行ごとに結合したい

エクセルの結合したセルをマクロで縦に分割する方法

Excel2007のマクロで文字列を結合

エクセルで複数のセルの内容を「ハイパーリンクを生かしたまま」単一のセルに結合したい

セルを結合するマクロ

注目のQ&A

カテゴリ
一覧

専門家に質問してみよう
専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

条件によってセルの結合を実行する方法

条件によってセルの結合を実行

質問者が選んだベストアンサー

その他の回答 (12)

お礼 2018/10/08 10:32

お礼 2018/10/08 10:32

お礼 2018/10/08 09:04

補足 2018/10/08 09:06

お礼 2018/10/07 23:15

お礼 2018/10/07 21:59

お礼 2018/10/07 19:45

お礼 2018/10/07 17:50

関連するQ&A

セルの結合マクロについて

Excel（セルの結合マクロ）

エクセルのセル～結合セルへのコピーの仕方を教えて

セル結合をマクロで行ないたい（その２）

数字が入力されているセルの結合

エクセル、セル結合について

エクセルのセルの結合について質問です。

VBAでの結合セルのコピー＆ペースト

(VBAにて)列のセルの結合について

Excel マクロ 条件によるセルの結合

エクセルで論理式が真の場合、セルの結合

エクセルのマクロで結合セルに値を貼り付けたい

セル結合部の合計額

エクセルで結合セルのコピー

異なるブックを結合した時のセル参照

エクセルで複数セルの文字を一回で行ごとに結合したい

エクセルの結合したセルをマクロで縦に分割する方法

Excel2007のマクロで文字列を結合

エクセルで複数のセルの内容を「ハイパーリンクを生かしたまま」単一のセルに結合したい

セルを結合するマクロ

注目のQ&A

カテゴリ 一覧

専門家に質問してみよう 専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

Excel マクロ条件によるセルの結合

カテゴリ
一覧

専門家に質問してみよう
専門家登録