同じ値の連続するセルを結合する[Excel](Range.Mergeメソッド)
同じ値の連続するセルを結合する
Excelは、表計算ソフトとしてよりも、方眼紙として使われているケースが多いと思う。
そこで、大活躍するのが(w)セルの結合機能だと思う。
多くのExcel使いは、データを蓄積するためのシートで見栄えをよくするためにセルの結合を多用しやがるので、Excelをフツーに使いたい私のような善良な市民はいつも迷惑をこうむるわけですw
それでもまあ、見栄えを整えるために連続する同じ値のセルを結合する、という操作はそれなりに発生するので、自動化してみようと考えた。
考え方
とりあえず、タテ方向1列限定で考えてみた。複数列複数行はなかなか大変そうなので、ひとまず保留。
処理の手順
指定した範囲の一番上のセルから順に下へ下へと進めていく。
- 同じ値のセルが連続していたら、先頭のセルを変数に格納し、同じ値のセルがいくつ続くかカウントする
- 異なる値のセルにぶつかった時点で、Resizeプロパティを用いて同じ値のセル領域を取得し、結合する
とまあ、このような手順を考えた。
コーディング
リスト1 標準モジュール
Public Sub mergeSameValueCells(ByVal targetRange As Range) If targetRange.Columns.Count > 1 Then _ Call makeUserSick("2列以上の範囲を渡すなぼけー!"): 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
とりあえず一通り書いてみただけなので、ちょっとクソコードw
1列のセル範囲を受け取って処理する想定。
したがって、引数で受け取ったセル範囲が複数列だったら、最初のところで何もせずに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)からの9行に処理が移る。
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
まず、1つ下のセルと値を比較して同じ値だったら、targetCellをtmpCellにぶち込んで、cntをインクリメントし、isToBeMergedをTrueにする。これで同じ値のセルを数えるモードに切り替えたことになる。
1つ下のセルと異なる値であったならば、このセルは結合する必要がないということだから、(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)で1つ下のセルと値を比較し、同じ値だったら、cntをインクリメントするだけで良い。
1つ下のセルと異なる値だったら、セルを結合しなければならないので、(7)からの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で回す、という算段。
使ってみた
次のコードで実験。
リスト2 標準モジュール
Public Sub testMergeSameValueCells() Call mergeSameValueCells(Selection) End Sub
選択範囲を引数として渡してmergeSameValueCellsを実行するだけのコード。
まずはこんな表を用意して、
この状態で実行。
ほれ、この通り。
ついでに、
こんな表でもやってみた。
バッチリです。
おわりに
とりあえず組み立ててみただけなので、そもそものロジック含め、まだまだ改良の余地がありそう。
Excelを方眼紙的に使うことを止めるだけの力はないので、各個撃破で対抗するしかないのよね……。
追記
重大な欠陥があったので、メソッドを作り直しました。