VBN セルの結合と、色分け

質問

VBN教えてください。
画像の左→右のようにしたいのですが、
まず、1列目の上下同じセルを結合します。
2列目、3列目は、1列目の結合範囲内で、上下同じセルを結合します。

さらに、結合された1列目を基準に、交互に色をつけたいのです。

詳しい方、教えていただけませんでしょうか。
よろしくお願い致します。

回答No.2

kkkkkm

C列の6は分割しなくていいと思いますので以下のような感じでいかがですか。
色は同じ色がわからなので適当です。CellColorSetのところで変更してください。

Sub Test()
Dim c As Range, d As Range
Dim FRow As Long, MFRow As Long, MLRow As Long, i As Long
Dim flg As Boolean: flg = False

Application.ScreenUpdating = False
Application.DisplayAlerts = False
FRow = 2
Call DrawLine(1, 3, 1)
For Each c In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If c.Value <> c.Offset(1, 0).Value Then
Range(Cells(FRow, 1), Cells(c.Row, 1)).Merge
Call DrawLine(1, 3, c.Row)
If flg = False Then
Call CellColorSet(1, FRow, 3, c.Row)
flg = True
Else
flg = False
End If
FRow = c.Offset(1, 0).Row
End If
Next
For i = 2 To 3
MFRow = 2
For Each c In Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
With Cells(c.Row, 1).MergeArea
MLRow = .Item(.Count).Row
End With
If MFRow = MLRow Then
Range(Cells(MFRow, i), Cells(MLRow, i)).Merge
Call DrawLine(i, i, c.Row)
MFRow = c.Offset(1, 0).Row
ElseIf MLRow <> c.Offset(2, 0).Row Then
If c.Value <> c.Offset(1, 0).Value Or c.Row = MLRow Then
Range(Cells(MFRow, i), Cells(c.Row, i)).Merge
Call DrawLine(i, i, c.Row)
MFRow = c.Offset(1, 0).Row
End If
End If
Next
Next
Columns("A:C").HorizontalAlignment = xlCenter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function DrawLine(ByVal FCol As Long, ByVal Ecol As Long, ByVal mRow As Long)
With Range(Cells(mRow, FCol), Cells(mRow, Ecol)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
End Function

Function CellColorSet(ByVal FCol As Long, ByVal FRow As Long, ByVal LCol As Long, ByVal CRow As Long)
With Range(Cells(FRow, FCol), Cells(CRow, LCol)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Function

お礼

できました！
ありがとうございます。
みなさん、すごいですね。