| |
横から失礼します
取り合えず、速くないけどこんなかな？
社名、人名、顧客コードの最大桁数+1を、RowSearchの定数の設定して下さい
取り合えず、各4桁に設定してあります
時間が無かったので、Testを行っていません
上手く行かなかったらゴメン
以下を同一の標準モジュールに記述して下さい
Public Sub Test()
Dim i As Long
Dim vntData As Variant
Dim rngScope As Range
Dim lngFound As Long
'シートＡのデータを配列に取得
With Worksheets("シートＡ")
vntData = Range(.Cells(2, 1), _
.Cells(65536, 4).End(xlUp)).Value
End With
'シートＢを探索
With Worksheets("シートＢ")
'探索範囲を取得
Set rngScope = Range(.Cells(2, 1), _
.Cells(65536, 3).End(xlUp)).Value
'シートＡのデータの終りまで繰り返し
For i = 1 To UBound(vntData, 1)
'社名、人名、顧客コードをKeyに探索範囲より探索
lngFound = RowSearch(vntData(i, 1), vntData(i, 2), _
vntData(i, 3), rngScope)
'もし、Keyと同じ物が有った場合
If lngFound <> -1 Then
'E列にシートＡのD列の値を代入
.Cells(lngFound, 5).Value = vntData(i, 4)
End If
Next i
End With
Set rngScope = Nothing
End Sub
Private Function RowSearch(vntKey1 As Variant, _
vntKey2 As Variant, _
vntKey3 As Variant, _
rngScope As Range) As Long
' 二進探索（複数探索Key）
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
Dim vntTmp As Variant
Dim lngStartAdd As Long
Dim vntKey As Variant
Const lngLen1 As Long = 4 '社名の最大桁数+1
Const lngLen2 As Long = 4 '人名の最大桁数+1
Const lngLen3 As Long = 4 '顧客コードの最大桁数+1
vntKey = Right(String(lngLen1, " ") & vntKey1, lngLen1) _
& Right(String(lngLen2, " ") & vntKey2, lngLen2) _
& Right(String(lngLen3, " ") & vntKey3, lngLen3)
With rngScope
lngStartAdd = .Row - 1
lngLow = 1
lngHigh = .Rows.Count
Do While lngLow <= lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
vntTmp = Right(String(lngLen1, " ") _
& .Cells(lngMiddle, 1).Value, lngLen1) _
& Right(String(lngLen2, " ") _
& .Cells(lngMiddle, 2).Value, lngLen2) _
& Right(String(lngLen3, " ") _
& .Cells(lngMiddle, 3).Value, lngLen3)
Select Case vntKey
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
RowSearch = lngStartAdd + lngMiddle
Else
RowSearch = -1
End If
End Function
|
|
- 03/8/26(火) 20:57 -
