内包判定 - Infomentのブログ～Excel VBA奮闘記～

あるセルが、ある範囲に含まれているかどうか知りたい。そんな場面に遭遇した。
f:id:Infoment:20190812211735p:plain

よく見かけるのが、Intersectメソッドの応用。
officetanaka.net

しかし今回は、複数のセルが、別の指定範囲に完全に内包されているかを知りたかった。例えば、↓のようなケースだ。
f:id:Infoment:20190812212038p:plain

Intersectメソッドを用いて、重なった部分のアドレスを調べてみる。

Sub OverlapConfirmation()
    Dim Range1(1 To 3) As Range
    Dim Range2(1 To 3) As Range
    Dim Result(1 To 3) As Range
    Dim arr(1 To 3) As Variant
    
    Dim i As Long
        For i = 1 To 3
            Set Range1(i) = Range("B4:C4").Offset(9 * (i - 1), i - 1)
            Set Range2(i) = Range("D2:F8").Offset(9 * (i - 1))
            Set Result(i) = Application.Intersect(Range1(i), Range2(i))
            
            If Result(i) Is Nothing Then
                arr(i) = "重複なし"
            Else
                arr(i) = Result(i).Address
            End If
        Next
        
        MsgBox Join(arr, vbNewLine)
End Sub

結果、一つ目が重なっていないことは分かるものの、このままでは一番下のように完全に含まれるかどうか判定できない。
f:id:Infoment:20190812212324p:plain

そこで今回は、二つの方法（ユーザー定義関数）を考えてみた。

１．重なった個数で判定。
次のように考える。

結果がNothingで無ければ、とにかく重なっている。
重なっているセルの個数が判定したい範囲と同じならば、内包されている。

Function OverlapConfirmation1(target_range1 As Range, _
                              target_range2 As Range) As Boolean
    Dim Result As Range
    Set Result = Application.Intersect(target_range1, target_range2)
        
        ' 二つの範囲に重なる部分があって、
        If Not Result Is Nothing Then
            ' 且つ、重なっているセル数が元のセル数と同じならば、
            If Result.Count = target_range1.Count Then
                ' 全て重なっている（つまり内包されている）。
                OverlapConfirmation1 = True
            End If
        End If
End Function

早速テストしてみよう。

Sub OverlapTest1()
    Dim Range1(1 To 3) As Range
    Dim Range2(1 To 3) As Range
    Dim arr(1 To 3) As Variant
    
    Dim i As Long
        For i = 1 To 3
            Set Range1(i) = Range("B4:C4").Offset(9 * (i - 1), i - 1)
            Set Range2(i) = Range("D2:F8").Offset(9 * (i - 1))
            ' 内包判定。
            arr(i) = OverlapConfirmation1(Range1(i), Range2(i))
        Next
        
        MsgBox Join(arr, vbNewLine)
End Sub

結果は、以下のとおり。一応、予定通り。
f:id:Infoment:20190812213251p:plain

２．Unionメソッドで判定。
以前、このような試みを行った。
infoment.hatenablog.com

この時は結論として、「どちらか一方が他方を内包する場合、小さい方は飲み込まれて消えてしまうらしい」ということが分かった。これを応用する。

Function OverlapConfirmation2(target_range1 As Range, _
                              target_range2 As Range) As Boolean
    Dim Result As Range
    Set Result = Union(target_range1, target_range2)
        ' Unionメソッドの結果がtarget_range2と同じならば、
        If Result.Address = target_range2.Address Then
            ' target_range1はtarget_range2に内包されている。
            OverlapConfirmation2 = True
        End If
End Function

こちらもテストしてみよう。

Sub OverlapTest2()
    Dim Range1(1 To 3) As Range
    Dim Range2(1 To 3) As Range
    Dim arr(1 To 3) As Variant
    
    Dim i As Long
        For i = 1 To 3
            Set Range1(i) = Range("B4:C4").Offset(9 * (i - 1), i - 1)
            Set Range2(i) = Range("D2:F8").Offset(9 * (i - 1))
            ' 内包判定。
            arr(i) = OverlapConfirmation2(Range1(i), Range2(i))
        Next
        
        MsgBox Join(arr, vbNewLine)
End Sub