こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

階層に並んでいるデータがあります。
 (1階層)     (2階層)   (3階層)   (4階層)   (5階層)
A1 ビジネステーマ > マーケット > サービス > 資料 > ナンバー
A2  (セル結合) (セル結合) (セル結合) (セル結合) (セル結合)
A3  (セル結合) (セル結合) (セル結合) (セル結合) (セル結合)
A4  (セル結合) (セル結合) (セル結合) (セル結合) (セル結合)
A5  (セル結合) (セル結合) (セル結合) (セル結合) (セル結合)
A6 ビジネステーマ >  特定 > 拡張 > プロジェクト > 見積
A7  (セル結合) (セル結合) (セル結合) (セル結合) (セル結合)
 ・
 ・
 ・
A1のビジネステーマとA6のビジネステーマは同じなので、セル結合するようにマクロ実行をしたいです。
もし、その条件でマクロを実行するとしたら、問題なのは下記です。
2階層は別々なのに、たまたま3階層の名称が同じであった場合は結合してしまうことです。
(1階層)    (2階層)      (3階層)
エネルギー  >  地銀関連  >  自治体マーケット
エネルギー  >  地方    >  自治体マーケット

間違い
エネルギー  >  地銀関連  >  自治体マーケット
(セル結合) >  地方    >  (セル結合)

正解
エネルギー  >  地銀関連  >  自治体マーケット
(セル結合) >  地方    >  自治体マーケット

一段上の階層の名称が別々であれば、以下の階層は別々に結合するといった条件はどのようにしたら良いでしょうか?

なかなか難しいかと思いますが、いい方法がありましたら教えてください。
宜しくお願いします。

投稿日時 - 2018-10-07 11:11:40

QNo.9545127

困ってます

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

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

投稿日時 - 2018-10-08 08:55:45

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(13)

ANo.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 09:47:49

お礼

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

投稿日時 - 2018-10-08 10:32:11

ANo.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 09:30:27

お礼

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

投稿日時 - 2018-10-08 10:32:39

ANo.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 01:11:47

補足

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

投稿日時 - 2018-10-08 09:06:07

お礼

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

投稿日時 - 2018-10-08 09:04:54

ANo.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

投稿日時 - 2018-10-08 00:28:54

ANo.8

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

投稿日時 - 2018-10-08 00:03:12

ANo.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

投稿日時 - 2018-10-07 23:59:15

ANo.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 22:37:22

お礼

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

投稿日時 - 2018-10-07 23:15:21

ANo.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 20:23:38

お礼

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

投稿日時 - 2018-10-07 21:59:04

ANo.4

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

投稿日時 - 2018-10-07 19:20:08

お礼

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

投稿日時 - 2018-10-07 19:45:31

ANo.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 16:11:00

お礼

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

投稿日時 - 2018-10-07 17:50:01

ANo.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

投稿日時 - 2018-10-07 15:24:58

ANo.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

投稿日時 - 2018-10-07 13:11:22

お礼

今回も回答をありがとうございます。
マクロ実行してみましたところ、成功していますが、試しに名称を変えてみましたら、うまくいきませんでした。
青い枠が名称を変えた箇所です。赤い枠が本来ならセル結合するはずです。
それが結合していませんでした。

投稿日時 - 2018-10-07 15:46:17