【ExcelVBA】IPアドレスの自動比較。特定のIPアドレスが複数のネットワークのどれに一致しているか判断する。

Option Explicit
Sub test()
    Dim リスト, リスト2次配列 As Variant
    Dim 検索アドレス, 検索結果 As String
    Dim 開始行, 情報列, 終了行 As Long
    開始行 = Selection(1).Row
    情報列 = Selection(1).Column
    終了行 = Cells(Rows.Count, 情報列).End(xlUp).Row
    リスト2次配列 = Range(Cells(開始行, 情報列), Cells(終了行, 情報列))
    リスト = WorksheetFunction.Transpose(WorksheetFunction.Index(リスト2次配列, 0, 1))
    検索アドレス = InputBox("検索したいIPアドレスを入力してください。" & vbCrLf & _
                    "例：10.1.1.21/24")
    If 検索アドレス = "" Then
        MsgBox "処理を中止します。"
        Exit Sub
    End If
    検索結果 = リストに最も一致する値を返す(リスト, 検索アドレス)
    If 検索結果 = Empty Then
        MsgBox 検索アドレス & "はアドレスリストのネットワークに一致しません。"
    Else
        検索結果 = InputBox(Prompt:=検索アドレス & "は下記アドレスに含まれます。", Default:=検索結果)
    End If
End Sub


Function リストに最も一致する値を返す(ByVal リスト As Variant, ByVal 検索値 As String) As String
    Dim 検索値CIDR As Integer
    ReDim 比較先CIDR(UBound(リスト)) As Integer
    
    If 検索値 Like "*/*" Then
        検索値CIDR = Split(検索値, "/")(1)
    Else
        検索値CIDR = 32
    End If
    
    Dim 検索値2進数, 比較先2進数 As String
    Dim i, ビット捜査値, 最大一致ビット値 As Long
    For i = 1 To UBound(リスト)
        If リスト(i) Like "*/*" Then
            比較先CIDR(i) = Split(リスト(i), "/")(1)
        Else
            比較先CIDR(i) = 32
        End If
        
        If 比較先CIDR(i) > 検索値CIDR Then
            GoTo コンテニュー
        End If
        検索値2進数 = アドレス10進数から2進数(検索値)
        比較先2進数 = アドレス10進数から2進数(リスト(i))
        
        If 比較先2進数 = 検索値2進数 Then
            ビット捜査値 = 32
        Else
            ビット捜査値 = 0
            Do Until Mid(比較先2進数, ビット捜査値 + 1, 1) <> Mid(検索値2進数, ビット捜査値 + 1, 1)
                ビット捜査値 = ビット捜査値 + 1
            Loop
        End If
        If 比較先CIDR(i) <= ビット捜査値 And 最大一致ビット値 < ビット捜査値 Then
            最大一致ビット値 = 比較先CIDR(i)
            リストに最も一致する値を返す = リスト(i)
        End If
コンテニュー:
    Next
End Function
Function アドレス10進数から2進数(ByVal アドレス As String) As String
    Dim アドレスCIDR無し As String
    If アドレス Like "*/*" Then
        アドレスCIDR無し = Split(アドレス, "/")(0)
    Else
        アドレスCIDR無し = アドレス
    End If
    
    Dim オクテット値 As Variant
    Dim オクテット値2進数, 余り As String
    For Each オクテット値 In Split(アドレスCIDR無し, ".")
        オクテット値2進数 = ""
        余り = ""
        Do Until オクテット値 < 2
            余り = オクテット値 Mod 2
            オクテット値 = Int(オクテット値 / 2)
            オクテット値2進数 = 余り & オクテット値2進数
        Loop
        オクテット値2進数 = Format(オクテット値 & オクテット値2進数, "00000000")
        アドレス10進数から2進数 = アドレス10進数から2進数 & オクテット値2進数
    Next
End Function