セル範囲が格子状になっているか判定するFunction(Excel)

セル範囲が格子状になっているか判定するFunction

いわゆる「Excel方眼紙」との戦いの一環。

セル結合とかガンガンズンズングイグイかまして作った表が、格子状になっているか判定する必要に迫られたのだった。

かつて誰かが作ったツールに不具合があって、変なエラーが出る、と報告を受けたので、ちょっと修正してみようと思ったら、すっげーアクロバチックなコードで実装されていてびっくり仰天したのであった。

んで、やってみたら、負けず劣らずアクロバチックなコードになったという……。

一つの道しるべとして残しておく。

考えかた

とりあえず、RangeオブジェクトのMergeAreaプロパティを使えば、結合されているセルのTopLeftの位置が取得できる（[Range].MergeArea(1, 1)でTopLeftのセルが返る）ので、これを利用しようと考えた。

たとえば、セル範囲の１行目について、一つづつヨコ方向に進んで、TopLeftセルの列番号が変わるごとに配列にぶち込んでいく。

２行目以降も、同じように一つづつヨコ方向に進み、同じくTopLeftセルの列番号が変わるごとに配列にぶち込んでいく。

一つ目の配列と二つ目の配列を比較して、要素が異なっていたら、格子状になっていないということなのでFalseを返す。

一つ目の配列と二つ目の配列が全く同じだったら、次の行に進む。

最後の行まで完走しても、全て二つの配列が全く同じだったら、Trueを返す。

タテ方向についても同じように調べる。

ヨコ・タテ両方ともTrueが返るなら、そのセル範囲は格子状になっている、ということなので、Trueを返す。

このような考えかたでコーディングしてみた。

列方向の区切り位置を調べるFunction

リスト１　標準モジュール

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

で、対象のセル範囲の１行目をスキャンし、列区切り位置の配列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を作成する。

ただし、１行スキャンするごとに(4)の

If Not isTheSame(criterionArray, compareArray) Then Exit Function

(5)のisTheSameを呼び出して、二つの配列「criterionArray」と「compareArray」を比較。少しでも異なっていたら、即Falseを返すようにしている。

リスト２　標準モジュール

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を返せば、対象のセル範囲は格子状になっている、ということになる（と思う……）。

リスト３　標準モジュール

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方眼紙が横行している現場は大変です。