ExcelのVBAで二分探索(BinarySearch)

ExcelのVBAで、Rangeオブジェクト.Findメソッドで値を取らせようとしていたのですが、日付型を文字列や日付型と解釈しているようで、バシッと求める値が取れない。そんな苦労に悩まされました。
こんな不安定なメソッドは使えない―――――

だから、必死で二分探索の検索をさせる関数を実装しました。
アルゴリズムは、

１．半分に割っていって、大きいか小さいかを見る。
２．大か小かで、上限と下限を切り詰めていく。

例：10000個データがある場合
　まず半分の5000で割って、大小を見る。
　検索したい方が大きいなら、上限を5000下に動かす。
　検索したい方が小さいなら、下限を5000上に動かす。

　次は、その範囲内の5000を、半分の2500で割って、大小を見る。
　検索したい方が大きいなら、上限を2500下に動かす。
　検索したい方が小さいなら、下限を2500上に動かす。

　・・・これを延々と繰り返し、ついに割り切れなくなるところまで行く。

　分割するにも限りがあるわけで、「じゃあ何回繰り返せばよいの？」っていうと、
　$ \begin{equation} 10000=2222 \cdots \end{equation}$
で、$2$ が何個続くか、ってことなので、結局　$ \begin{equation} 2^a < 10000 < 2^{a+1} \end{equation}$　となる $a$ をみつければよい、ということになります。
　上式で、全部 $2$ の対数をかぶせたら
　$ \begin{equation} \log_2 2^a < \log_2 10000 < \log_2 2^{a+1} \end{equation}$　となるから、両端の $\log$ が外れて
　　　　$ \begin{equation} a < \log_2 10000 < a+1 \end{equation}$
となります。
　だから、$ \log_2 10000 $ を超えなければ良い、というのが答えになります。

　VBA上では　Log関数: Log(対数を取りたい数)　というのが用意されています。
　ところが、Log(10000) ってやっても、底が $2$ じゃなくて、自然対数の $\log_e 10000$ が出力されます。
　今欲しいのは $\log_{\color{#00CC99}{e}} 10000$ ではなく、 $\log_{\color{red}{2}} 10000$ です。

　VBA上で引っ張り出せるのは、 $\log_{\color{#00CC99}{e}} 10000$ と $\log_{\color{#00CC99}{e}}{\color{red}{2}}$ だけ。(自然対数しかないから)

　どうやって、 $\log_{\color{red}{2}}10000$ を出せばよいか。底の変換公式をつかいます。
　$\log_{\color{red}{a}}x=A 　\cdots (1)$　より、　${\color{red}{a}}^A=x 　\cdots (1)'$
　$\log_{\color{#00CC99}{e}}x=B　\cdots (2)$　より、　${\color{#00CC99}{e}}^B=x 　\cdots (2)'$
　$\log_{\color{#00CC99}{e}}\color{red}{a}=C　\cdots (3)$　より、　${\color{#00CC99}{e}}^C={\color{red}{a}} 　\cdots (3)'$

　ここで、$A$ を $B$ と $C$ で表せればよい。$(3)'$ をいじって　${({\color{#00CC99}{e}}^C)}^A={\color{red}{a}}^A=x={\color{#00CC99}{e}}^B$
　よって ${\color{#00CC99}{e}}^{CA}={\color{#00CC99}{e}}^B$ だから、$CA=B$。
　$ゆえに、\displaystyle A=\frac{B}{C} 　・・・ということで、\log_{\color{red}{a}}x=\frac{\log_{\color{#00CC99}{e}}x}{\log_{\color{#00CC99}{e}}\color{red}{a}}$

　$たとえば、\displaystyle \log_{\color{red}{2}} 10000　がほしいなら、\log_{\color{red}{2}}10000=\frac{\log_{\color{#00CC99}{e}}10000}{\log_{\color{#00CC99}{e}}\color{red}{2}}=\frac{{\rm Log}(10000)}{{\rm Log}(2)}$　

小数点を切り捨てたら、サーチしたい個数以上に分割することもないでしょう。
だから、Excel VBA 上では、RoundDown(Log(サーチしたい個数) / Log(2#), 0)。
これで、ループさせるべき回数を取得できます。
ループの回数を、$\log{x}/\log{2}$ を切り捨てた整数、までにしたら、本当に最小単位の３つまで切り詰めていて、サクサク動いてくれて感動しました。

見ていくデータにそのものズバリの値が入ってない時は、周辺を調べて確定しなければならないんですよね。これが鬱陶しかったです。
ここは、Updownというフラグを設けて、同一数値が複数あった場合に、上から取らせるか、下から取らせるかを選ばせるようにしました。苦肉の策です。

DBだったらクエリ1個書いたら終わるのに。
EXCELでクエリの機能を実装すると、こんなに大変なのか、ということが身にしみてわかりました。

もろもろ苦しみながらも、デバッグした結果、動作確認OK。
もちろん、修正の余地は大いにありですが、とりあえず、これにて、一応完成。
プロトタイプ版として。

BinarySearch.bas

'ニ分探索法
Function lng_fnc_BinarySearch_EnableApproximation(ByVal UpDown As Integer, _
                            ByVal SearchObject, ByVal SSht As Worksheet, _
                            ByVal SRow As Long, ByVal ERow As Long, _
                            ByVal SCol As Long, ByVal ECol As Long) As Long
    Dim wSht As Worksheet: Set wSht = SSht
    Dim lLP As Long
    Dim lngNum As Long: lngNum = ERow - SRow + 1
    
    Dim intlog2num As Long: intlog2num = Application.WorksheetFunction.RoundDown(Log(lngNum) / Log(2#), 0)  'ニ分探索法の回数
    Dim Crit, Crit1, Crit2
    Dim RCrit1 As Long: RCrit1 = SRow
    Dim RCrit2 As Long: RCrit2 = ERow
    Dim RCrit As Long: RCrit = Round((RCrit1 + RCrit2) / 2, 0)
    Dim FLG_Yarinokosi As Integer: FLG_Yarinokosi = 0   '最小単位の3つまで詰めたけど特定できなかった、という意味
    
    With wSht
        Crit = .Cells(RCrit, SCol).Value
        Crit1 = .Cells(RCrit1, SCol).Value
        Crit2 = .Cells(RCrit2, SCol).Value
    
    For lLP = 1 To intlog2num
        If Crit > SearchObject Then
           RCrit2 = Round((RCrit1 + RCrit2) / 2)
        ElseIf Crit < SearchObject Then
           RCrit1 = Round((RCrit1 + RCrit2) / 2)
        Else
            FLG_Yarinokosi = 1 '次は、周辺を調べなければならない
            Exit For
        End If
        RCrit = Round((RCrit1 + RCrit2) / 2)
        Crit = .Cells(RCrit, SCol).Value
        Crit1 = .Cells(RCrit1, SCol).Value
        Crit2 = .Cells(RCrit2, SCol).Value
    Next lLP
        
    'もう既に該当値に来ている時
    If FLG_Yarinokosi = 1 Then
        Select Case UpDown
        Case 1: 'もし、一番最初が行頭なら
                If .Cells(RCrit - 1, SCol).Value <> .Cells(RCrit, SCol).Value Then
                    lng_fnc_BinarySearch_EnableApproximation = RCrit: Exit Function
                Else    '一番最初が行頭でないなら
                    While .Cells(RCrit - 1, SCol).Value = .Cells(RCrit, SCol).Value Or RCrit <= 3
                        RCrit = RCrit - 1
                    Wend
                    lng_fnc_BinarySearch_EnableApproximation = RCrit: Exit Function
                End If
        Case 2: 'もし、一番最初が行末なら
                If .Cells(RCrit + 1, SCol).Value <> .Cells(RCrit, SCol).Value Then
                    lng_fnc_BinarySearch_EnableApproximation = RCrit: Exit Function
                Else    '一番最初が行末でないなら
                    While .Cells(RCrit + 1, SCol).Value = .Cells(RCrit, SCol).Value Or RCrit <= 3
                        RCrit = RCrit + 1
                    Wend
                    lng_fnc_BinarySearch_EnableApproximation = RCrit: Exit Function
                End If
        End Select
        FLG_Yarinokosi = 0
    
    'まだ該当値に来ていない時
    Else
        'そのブロックの1から回して、精密に仕上げる
           For lLP = RCrit1 To RCrit2
                Select Case UpDown
                Case 1:
                    If .Cells(lLP, SCol).Value < SearchObject And SearchObject <= .Cells(lLP + 1, SCol).Value Then
                        lng_fnc_BinarySearch_EnableApproximation = lLP + 1: Exit Function
                    End If
                Case 2:
                    If .Cells(lLP, SCol).Value = SearchObject And SearchObject < .Cells(lLP + 1, SCol).Value Then
                        lng_fnc_BinarySearch_EnableApproximation = lLP: Exit Function
                    End If
                End Select
           Next lLP
        'それでなかったら､さすがにエラーを出す｡
        lng_fnc_BinarySearch_EnableApproximation = 0
    End If
    End With
    Set wSht = Nothing