同じ値の連続するセルを結合する
Excelは、表計算ソフトとしてよりも、方眼紙として使われているケースが多いと思う。
そこで、大活躍するのが（ｗ）セルの結合機能だと思う。
多くのExcel使いは、データを蓄積するためのシートで見栄えをよくするためにセルの結合を多用しやがるので、Excelをフツーに使いたい私のような善良な市民はいつも迷惑をこうむるわけですｗ
それでもまあ、見栄えを整えるために連続する同じ値のセルを結合する、という操作はそれなりに発生するので、自動化してみようと考えた。
考え方
とりあえず、タテ方向１列限定で考えてみた。複数列複数行はなかなか大変そうなので、ひとまず保留。
処理の手順
指定した範囲の一番上のセルから順に下へ下へと進めていく。
- 同じ値のセルが連続していたら、先頭のセルを変数に格納し、同じ値のセルがいくつ続くかカウントする
- 異なる値のセルにぶつかった時点で、Resizeプロパティを用いて同じ値のセル領域を取得し、結合する
とまあ、このような手順を考えた。
コーディング
リスト１ 標準モジュール
Public Sub mergeSameValueCells(ByVal targetRange As Range)
If targetRange.Columns.Count > 1 Then _
Call makeUserSick("２列以上の範囲を渡すなぼけー！"): Exit Sub
Dim cnt As Long
Dim targetCell As Range
Dim tmpCell As Range
Dim isToBeMerged As Boolean '……(1)'
cnt = 1
For Each targetCell In targetRange
With targetCell
If Not isToBeMerged Then '……(2)'
If .Value = .Offset(1, 0).Value Then '……(3)'
Set tmpCell = targetCell
cnt = cnt + 1
isToBeMerged = True
Else '……(4)'
Set tmpCell = targetCell
tmpCell.HorizontalAlignment = xlCenter
tmpCell.VerticalAlignment = xlCenter
End If
Else '(If isToBeMerged Then)' '……(5)'
If .Value = .Offset(1, 0).Value Then '……(6)'
cnt = cnt + 1
Else '(If .Value <> .Offset(1, 0).Value)' '……(7)'
Application.DisplayAlerts = False
tmpCell.Resize(cnt, 1).Merge
Application.DisplayAlerts = True
tmpCell.HorizontalAlignment = xlCenter
tmpCell.VerticalAlignment = xlCenter
isToBeMerged = False
cnt = 1
End If
End If
End With
Next
End Sub
とりあえず一通り書いてみただけなので、ちょっとクソコードｗ
１列のセル範囲を受け取って処理する想定。
したがって、引数で受け取ったセル範囲が複数列だったら、最初のところで何もせずにreturnしている。
まず、(1)の
Dim isToBeMerged As Boolean
はフラグ変数。ざっくりと言えば、セル連結モードになっているかどうかを表す変数。
isToBeMergedがTrueのときは同じ値のセルを数えている途中、と考えてもらえば良い。
んで、メインの処理。まずは(2)からの23行（！）
If Not isToBeMerged Then If .Value = .Offset(1, 0).Value Then '……(3)' Set tmpCell = targetCell cnt = cnt + 1 isToBeMerged = True Else '……(4)' Set tmpCell = targetCell tmpCell.HorizontalAlignment = xlCenter tmpCell.VerticalAlignment = xlCenter End If Else '(If isToBeMerged Then)' '……(5)' If .Value = .Offset(1, 0).Value Then '……(6)' cnt = cnt + 1 Else '(If .Value <> .Offset(1, 0).Value)' '……(7)' Application.DisplayAlerts = False tmpCell.Resize(cnt, 1).Merge Application.DisplayAlerts = True tmpCell.HorizontalAlignment = xlCenter tmpCell.VerticalAlignment = xlCenter isToBeMerged = False cnt = 1 End If End If
まず、isToBeMergedがFalseのとき、すなわち、同じ値のセルを数える体勢になっていない状態のときには、(3)からの９行に処理が移る。
If .Value = .Offset(1, 0).Value Then Set tmpCell = targetCell cnt = cnt + 1 isToBeMerged = True Else '……(4)' Set tmpCell = targetCell tmpCell.HorizontalAlignment = xlCenter tmpCell.VerticalAlignment = xlCenter End If
まず、１つ下のセルと値を比較して同じ値だったら、targetCellをtmpCellにぶち込んで、cntをインクリメントし、isToBeMergedをTrueにする。これで同じ値のセルを数えるモードに切り替えたことになる。
１つ下のセルと異なる値であったならば、このセルは結合する必要がないということだから、(4)のElseブロックを実行して、値のセンタリングだけしておく。
次に、isToBeMergedがTrueのとき、すなわち、すでに同じ値のセルを数える体勢に入っているときは、(5)から下の11行に処理が移る。
If .Value = .Offset(1, 0).Value Then '……(6)' cnt = cnt + 1 Else '(If .Value <> .Offset(1, 0).Value)' '……(7)' Application.DisplayAlerts = False tmpCell.Resize(cnt, 1).Merge Application.DisplayAlerts = True tmpCell.HorizontalAlignment = xlCenter tmpCell.VerticalAlignment = xlCenter isToBeMerged = False cnt = 1 End If
(6)で１つ下のセルと値を比較し、同じ値だったら、cntをインクリメントするだけで良い。
１つ下のセルと異なる値だったら、セルを結合しなければならないので、(7)からの７行の処理を行う。
Application.DisplayAlerts = False tmpCell.Resize(cnt, 1).Merge Application.DisplayAlerts = True tmpCell.HorizontalAlignment = xlCenter tmpCell.VerticalAlignment = xlCenter isToBeMerged = False cnt = 1
まず、セルを結合するときには一番左上の値しか残らないとか何とか警告メッセージが出るので、Application.DisplayAlertsをFalseにしておく。
次に、tmpCell（同じ値のセルを数え始めたときの最初のセル）のResizeプロパティに引数としてcnt（同じ値のセルの個数）を渡して同じ値の連続するセル範囲を取得し、Mergeメソッドで結合。即座にApplication.DisplayAlertsをTrueに戻しておく。
後は、HorizontalAlignmentプロパティとVerticalAlignmentプロパティの値をxlCenterに設定して中央寄せにし、isToBeMergedをFalseにしてモードをリセットしておく。
これをFor Eachで回す、という算段。
使ってみた
次のコードで実験。
リスト２ 標準モジュール
Public Sub testMergeSameValueCells() Call mergeSameValueCells(Selection) End Sub
選択範囲を引数として渡してmergeSameValueCellsを実行するだけのコード。
まずはこんな表を用意して、
この状態で実行。
ほれ、この通り。
ついでに、
こんな表でもやってみた。
バッチリです。
おわりに
とりあえず組み立ててみただけなので、そもそものロジック含め、まだまだ改良の余地がありそう。
Excelを方眼紙的に使うことを止めるだけの力はないので、各個撃破で対抗するしかないのよね……。
追記
重大な欠陥があったので、メソッドを作り直しました。
