VBN セルの結合と、色分け

質問

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

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

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

回答No.3

SI299792 · ベストアンサー

上げたサンプルでは、
Ｂ列が変わったらＣ列を分割するのか
Ｂ列が変わってもＣ列を分割しないのか
両方のパターンがあり、どっちか判りません。
今回は、Ｂ列が変わったらＣ列を分割するパターンです。

Option Explicit
Option Base 1
'
Sub Macro1()
　　Dim Row As Long
　　Dim MergeFlg As Boolean
　　Dim Col As Integer
　　Dim STartArr(3) As Long
　　Dim Start As Variant
　　Dim ColorFlg As Boolean
'
　　Application.DisplayAlerts = False
'
　　For Row = 2 To [A1].End(xlDown).Row
　　　　MergeFlg = False
'
　　　　If Cells(Row, "A") <> Cells(Row + 1, "A") Then
　　　　　　Start = STartArr(1) + 2
　　　　　　ColorFlg = Not ColorFlg
'
　　　　　　If ColorFlg Then
　　　　　　　　Cells(Start, "A").Resize(Row - Start + 1, 3) _
　　　　　　　　　　.Interior.Color = &HDAE9FC
　　　　　　End If
　　　　End If
'
　　　　For Col = 1 To 3
'
　　　　　　If Cells(Row, Col) <> Cells(Row + 1, Col) Or MergeFlg Then
　　　　　　　　Start = STartArr(Col) + 2
　　　　　　　　Cells(Start, Col).Resize(Row - Start + 1).Merge
　　　　　　　　STartArr(Col) = Row - 1
　　　　　　　　MergeFlg = True
　　　　　　End If
　　　　Next Col
　　Next Row
　　Range("A1:C" & Row).Borders(xlInsideHorizontal).LineStyle = xlContinuous
　　Application.DisplayAlerts = True
End Sub

お礼

細かいところまで配慮いただき、ありがとうございます。
説明至らなく、申し訳ありませんでした。
少し、アレンジもでき、実施したいこと、解決できました。
私も自分で作れたらと思うのですが、基礎がないのでなかなか。。。
ありがとうございました。

回答No.4

imogasi

すでに２回答が出ているが、当方でもやってみたので、参考に。
例データ　質問例を使う　Sheet2　A1:C21に、元データをコピーしてテストがよい。
１列目 ２列目 ３列目
a 1 5
a 1 5
b 1 6
b 1 6
b 1 6
b 1 7
b 1 7
b 1 7
b 1 7
c 2 7
c 2 7
c 2 7
c 2 7
c 2 7
d 2 6
d 2 6
d 2 6
d 2 6
d 3 6
d 3 6
ーー
大切な前提
A列を第Iソートキー
B列を第２ソートキー
でソートしてあるものとする。
ーーー
標準モジュールに
Sub test02()
Application.DisplayAlerts = False
Dim flg As Boolean
flg = True
Set sh1 = Worksheets("Sheet2")
'--
lr = sh1.Range("a10000").End(xlUp).Row
´MsgBox lr
'--初期設定
mk = sh1.Cells(2, "A") & "-" & sh1.Cells(2, "B") 'A列＋B列キー
s = 2 'スタートデータ行
r = 1 '結合範囲の行数
'---´各行で上行から繰り返し処理
For i = 3 To lr
k = sh1.Cells(i, "A") & "-" & sh1.Cells(i, "B")
If k = mk Then 'A列とB列文字列組み合わせで、変わったかどうから
r = r + 1
Else
'---変わった
sh1.Range("A" & s & "：A" & s + r - 1).MergeCells = True
sh1.Range("B" & s & "：B" & s + r - 1).MergeCells = True
sh1.Range("A" & s & "：C" & s + r - 1).Borders(xlBottom).LineStyle = xlSingle
'---塗りつぶしの色
If flg = True Then
sh1.Range("A" & s & "：C" & s + r - 1).Interior.Color = rgbYellow
Else
sh1.Range("A" & s & "：C" & s + r - 1).Interior.Color = rgbPink
End If
flg = Not flg '反転
'--
s = i
r = 1
End If
mk = sh1.Cells(i, "A") & "-" & sh1.Cells(i, "B")
Next i
'--データが終わった最後の後じまい
sh1.Range("A" & s & "：A" & s + r - 1).MergeCells = True
sh1.Range("A" & s & "：A" & s + r - 1).MergeCells = True
sh1.Range("B" & s & "：B" & s + r - 1).MergeCells = True
sh1.Range("A" & s & "：C" & s + r - 1).Borders(xlBottom).LineStyle = xlSingle
'---
If flg = True Then
sh1.Range("A" & s & "：C" & s + r - 1).Interior.Color = rgbYellow
Else
sh1.Range("A" & s & "：C" & s + r - 1).Interior.Color = rgbPink
End If
'----
Application.DisplayAlerts = True
End Sub
ーーー
塗りつぶしの色は黄色とピンクのような、薄い色にしている。
その他の色にするなら、WEBで「VBA　塗りつぶし色　RGB」で調べてください。
テストを繰り返す場合は、例えば下記を使ってクリアするとよい。
Sub test03()
Set sh1 = Worksheets("Sheet2")
'--テスト時用
sh1.Cells.Clear
sh1.Range("a1:C10000").MergeCells = False
sh1.Range("a1:C21").Interior.Color = xlNone
End Sub
ーー
実行結果　下記は回答記事では、列が崩れるかも（もちろん色は出ていない）しれないので、自分の実行結果の方を見てください。
１列目 ２列目 ３列目
a 1 5
5
b 1 6
6
6
7
7
7
7
c 2 7
7
7
7
7
d 2 6
6
6
6
d 3 6
6

お礼

解説もつけていただいてありがとうございます。
わかりやすかったです。

回答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

お礼

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

回答No.1

SI299792

VBN が何だかわからないので、VBA で作りました。
C10 は隣のB10 が変化してますが、分割しなくていいのですか。

Option Explicit
Option Base 1
'
Sub Macro1()
　　Dim Row As Long
　　Dim MergeFlg As Boolean
　　Dim Col As Integer
　　Dim STartArr(3) As Long
　　Dim Start As Variant
　　Dim ColorFlg As Boolean
'
　　Application.DisplayAlerts = False
'
　　For Row = 2 To [A1].End(xlDown).Row
　　　　MergeFlg = False
'
　　　　If Cells(Row, "A") <> Cells(Row + 1, "A") Then
　　　　　　Start = STartArr(1) + 2
　　　　　　MergeFlg = True
　　　　　　ColorFlg = Not ColorFlg
'
　　　　　　If ColorFlg Then
　　　　　　　　Cells(Start, "A").Resize(Row - Start + 1, 3) _
　　　　　　　　　　.Interior.Color = &HDAE9FC
　　　　　　End If
　　　　End If
'
　　　　For Col = 1 To 3
'
　　　　　　If Cells(Row, Col) <> Cells(Row + 1, Col) Or MergeFlg Then
　　　　　　　　Start = STartArr(Col) + 2
　　　　　　　　Cells(Start, Col).Resize(Row - Start + 1).Merge
　　　　　　　　STartArr(Col) = Row - 1
　　　　　　End If
　　　　Next Col
　　Next Row
　　Range("A1:C" & Row).Borders(xlInsideHorizontal).LineStyle = xlContinuous
　　Application.DisplayAlerts = True
End Sub

お礼

早速ありがとうございます。
VBAでした、失礼しました。
そのまま使わせていただいて、できました。
なにが書いてあるか、理解できていないのですが、解読して、応用できるようにしたいです。
大変助かりました。