| |
面白そうなので私も作って見ました
A列順の、B列順の、C列順でソートされて要る事が条件
直接セル上で２分探索を行っているのでMatchよりは低速ですが
セルを直接にリニアサーチするより速いと思います
このコードでは、B、C列はOffsetで見ているので探索範囲（rngScope）は、
A列として与えてください
例では、探索Key1、Key2、Key3をリテラルとして入れていますが、
もちろん変数で受け渡してもOkです
また、A、B、C列の値は３桁までを想定していますが
それを変更すつのは、
Function BinarySearchCellsの
'桁数
Const lngPlace As Long = 3
を変更して下さい
Public Sub Test2()
Dim rngScope As Range
Dim vntKey As Variant
Dim lngFind As Long
Set rngScope = Range(Cells(6, 1), Cells(65536, 1).End(xlUp))
lngFind = BinarySearchCells(4, 5, 6, rngScope)
If lngFind <> -1 Then
MsgBox lngFind & "行です"
Else
MsgBox "探索値が有りません"
End If
Set rngScope = Nothing
End Sub
Public Function BinarySearchCells(vntKey1 As Variant, _
vntKey2 As Variant, _
vntKey3 As Variant, _
rngScope As Range) As Long
' 二進探索セル版
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
Dim vntTmp As Variant
Dim vntSearch As Variant
Dim lngStartAdd As Long
'桁数
Const lngPlace As Long = 3
'数値の場合
vntSearch = vntKey1 * 10 ^ (lngPlace * 2) _
+ vntKey2 * 10 ^ lngPlace _
+ vntKey3
'文字列の場合
' vntSearch = Right(String(lngPlace, "0") _
' & vntKey1, lngPlace) _
' & Right(String(lngPlace, "0") _
' & vntKey2, lngPlace) _
' & Right(String(lngPlace, "0") _
' & vntKey3, lngPlace)
With rngScope
lngStartAdd = .Row - 1
lngLow = 1
lngHigh = .Rows.Count
Do While lngLow <= lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
With .Cells(lngMiddle)
'数値の場合
vntTmp = .Offset(, 0).Value * 10 ^ (lngPlace * 2) _
+ .Offset(, 1).Value * 10 ^ lngPlace _
+ .Offset(, 2).Value
'文字列の場合
' vntTmp = Right(String(lngPlace, "0") _
' & .Offset(, 0).Value, lngPlace) _
' & Right(String(lngPlace, "0") _
' & .Offset(, 1).Value, lngPlace) _
' & Right(String(lngPlace, "0") _
' & .Offset(, 2).Value, lngPlace)
End With
Select Case vntSearch
Case Is > vntTmp
lngLow = lngMiddle + 1
Case Is < vntTmp
lngHigh = lngMiddle - 1
Case Is = vntTmp
lngLow = lngMiddle + 1
lngHigh = lngMiddle - 1
End Select
Loop
End With
If lngLow = lngHigh + 2 Then
BinarySearchCells = lngStartAdd + lngMiddle
Else
BinarySearchCells = -1
End If
End Function
|
|
- 03/6/9(月) 16:03 -
- 03/6/9(月) 20:31 -
