セル範囲が格子状になっているか判定するFunction(Excel)
セル範囲が格子状になっているか判定するFunction
いわゆる「Excel方眼紙」との戦いの一環。
セル結合とかガンガンズンズングイグイかまして作った表が、格子状になっているか判定する必要に迫られたのだった。
かつて誰かが作ったツールに不具合があって、変なエラーが出る、と報告を受けたので、ちょっと修正してみようと思ったら、すっげーアクロバチックなコードで実装されていてびっくり仰天したのであった。
んで、やってみたら、負けず劣らずアクロバチックなコードになったという……。
一つの道しるべとして残しておく。
考えかた
とりあえず、Range
オブジェクトのMergeArea
プロパティを使えば、結合されているセルのTopLeftの位置が取得できる([Range].MergeArea(1, 1)
でTopLeftのセルが返る)ので、これを利用しようと考えた。
たとえば、セル範囲の1行目について、一つづつヨコ方向に進んで、TopLeftセルの列番号が変わるごとに配列にぶち込んでいく。
2行目以降も、同じように一つづつヨコ方向に進み、同じくTopLeftセルの列番号が変わるごとに配列にぶち込んでいく。
一つ目の配列と二つ目の配列を比較して、要素が異なっていたら、格子状になっていないということなのでFalse
を返す。
一つ目の配列と二つ目の配列が全く同じだったら、次の行に進む。
最後の行まで完走しても、全て二つの配列が全く同じだったら、True
を返す。
タテ方向についても同じように調べる。
ヨコ・タテ両方ともTrue
が返るなら、そのセル範囲は格子状になっている、ということなので、True
を返す。
このような考えかたでコーディングしてみた。
列方向の区切り位置を調べるFunction
リスト1 標準モジュール
Private Function isHorisontalRegulated( _ ByVal targetRange As Range) As Boolean isHorisontalRegulated = False '……(1)' Dim criterionArray() As Long '……(2)' ReDim criterionArray(0) criterionArray(0) = targetRange.Cells(1, 1).MergeArea(1, 1).Column Dim n As Long n = 0 Dim j As Long For j = 2 To targetRange.Columns.Count With targetRange.Cells(1, j).MergeArea(1, 1) If .Column <> criterionArray(n) Then n = n + 1 ReDim Preserve criterionArray(n) criterionArray(n) = .Column End If End With Next Dim compareArray() As Long '……(3)' ReDim compareArray(0) Dim i As Long For i = 2 To targetRange.Rows.Count compareArray(0) = targetRange.Cells(i, 1).MergeArea(1, 1).Column n = 0 For j = 1 To targetRange.Columns.Count With targetRange.Cells(i, j).MergeArea(1, 1) If .Column <> compareArray(n) Then n = n + 1 ReDim Preserve compareArray(n) compareArray(n) = .Column End If End With Next If Not isTheSame(criterionArray, compareArray) _ Then Exit Function '……(4)' Next isHorisontalRegulated = True '……(6)' End Function Private Function isTheSame( _ ByRef criterionArray() As Long, _ ByRef compareArray() As Long) As Boolean '……(5)' isTheSame = False If UBound(criterionArray()) <> UBound(compareArray()) Then Exit Function If LBound(criterionArray()) <> LBound(compareArray()) Then Exit Function Dim i As Long For i = LBound(criterionArray()) To UBound(criterionArray()) If criterionArray(i) <> compareArray(i) Then Exit Function Next isTheSame = True End Function
まず、(1)の
isHorisontalRegulated = False
でデフォルト値を明示。別に無くてもよいのだけれど、明示しておくことに意義があると思う。
このFunction
の場合、一つでも不正な区切りが見つかったらその時点でFalse
確定なので、False
をデフォルト値にする。即returnでFalse
が返ることになる。
(2)からの15行
Dim criterionArray() As Long ReDim criterionArray(0) criterionArray(0) = targetRange.Cells(1, 1).MergeArea(1, 1).Column Dim n As Long n = 0 Dim j As Long For j = 2 To targetRange.Columns.Count With targetRange.Cells(1, j).MergeArea(1, 1) If .Column <> criterionArray(n) Then n = n + 1 ReDim Preserve criterionArray(n) criterionArray(n) = .Column End If End With Next
で、対象のセル範囲の1行目をスキャンし、列区切り位置の配列criterionArray
を作る。
たとえば、
このようなセル範囲だったら、[1, 3, 5, 8, 10]
という配列ができることになる。
(3)からの18行(実質17行)
Dim compareArray() As Long ReDim compareArray(0) Dim i As Long For i = 2 To targetRange.Rows.Count compareArray(0) = targetRange.Cells(i, 1).MergeArea(1, 1).Column n = 0 For j = 1 To targetRange.Columns.Count With targetRange.Cells(i, j).MergeArea(1, 1) If .Column <> compareArray(n) Then n = n + 1 ReDim Preserve compareArray(n) compareArray(n) = .Column End If End With Next If Not isTheSame(criterionArray, compareArray) _ Then Exit Function '……(4)' Next
では、criterionArray
を作ったときと同じやり方で配列compareArray
を作成する。
ただし、1行スキャンするごとに(4)の
If Not isTheSame(criterionArray, compareArray) Then Exit Function
(5)のisTheSame
を呼び出して、二つの配列「criterionArray
」と「compareArray
」を比較。少しでも異なっていたら、即False
を返すようにしている。
リスト2 標準モジュール
Private Function isVerticalRegulated(ByVal targetRange As Range) As Boolean isVerticalRegulated = False Dim criterionArray() As Long ReDim criterionArray(0) criterionArray(0) = targetRange.Cells(1, 1).MergeArea(1, 1).Row Dim n As Long n = 0 Dim i As Long For i = 2 To targetRange.Rows.Count With targetRange.Cells(i, 1).MergeArea(1, 1) If .Row <> criterionArray(n) Then n = n + 1 ReDim Preserve criterionArray(n) criterionArray(n) = .Row End If End With Next Dim compareArray() As Long ReDim compareArray(0) Dim j As Long For j = 2 To targetRange.Columns.Count compareArray(0) = targetRange.Cells(1, j).MergeArea(1, 1).Row n = 0 For i = 1 To targetRange.Rows.Count With targetRange.Cells(i, j).MergeArea(1, 1) If .Row <> compareArray(n) Then n = n + 1 ReDim Preserve compareArray(n) compareArray(n) = .Row End If End With Next If Not isTheSame(criterionArray, compareArray) Then Exit Function Next isVerticalRegulated = True End Function
コチラは、全く同じ考えかたで、タテ方向にスキャン。
ほとんど同じコードを二つも並べる、というのはうまくないけれど、とりあえず対策が思い浮かばない。
上記の二つのFunctionがともにTrue
を返せば、対象のセル範囲は格子状になっている、ということになる(と思う……)。
リスト3 標準モジュール
Public Function isGridShape(ByVal targetRange As Range) As Boolean isGridShape = True If isHorisontalRegulated(targetRange) And _ isVerticalRegulated(targetRange) Then Exit Function isGridShape = False End Function
使ってみる
まず、
この状態で、イミディエイト・ウインドウに
?isGridShape(Selection)
と打ち込んでみる。
意図どおり、False
が返った。
この状態で実行しても、
やはりFalse
が返る。意図どおり。
この状態で実行すると、
今度はTrue
が返った。意図どおりだ。
おわりに
Excel方眼紙が横行している現場は大変です。