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

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/07 15:24 回答No.2

一部修正 Sub Test2() 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 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

ログインすると、全ての回答が全文表示されます。

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

2018/10/07 13:11 回答No.1

どうでしょか？ Sub Test() 　　Dim c As Long, r As Long 　　Dim LevelName As String, pLevelName As String 　　Dim 始 As Long, 終 As Long 　　For c = 1 To 6 '1列から最終列の6列までループ　　　　始 = 2 　　　　LevelName = Cells(2, c).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 　　　　　　　　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 And _ 　　　　　　　　　　Cells(r, c - 1).MergeArea.Item(1).Value = pLevelName Then 　　　　　　　　　　終 = r - 1 　　　　　　　　　　LevelName = Cells(r, c).MergeArea.Item(1).Value 　　　　　　　　　　pLevelName = Cells(r, c - 1).MergeArea.Item(1).Value 　　　　　　　　　　Application.DisplayAlerts = False 　　　　　　　　　　Range(Cells(始, c), Cells(終, c)).Merge 　　　　　　　　　　Application.DisplayAlerts = True 　　　　　　　　　　始 = r 　　　　　　　　End If 　　　　　　Next 　　　　End If 　　Next End Sub

質問者