ベストアンサー

※ 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

質問者