| |
少しは、速いかな？
顧客リストは、顧客番号の昇順で整列されている必要が有ります
また、「Option Compare Text」は必ず入れて下さい
Option Explicit
Option Compare Text
Public Sub Sample()
Dim i As Long
Dim rngSales As Range
Dim vntSales As Variant
Dim vntCustomer As Variant
Dim vntResult As Variant
Dim lngRows As Long
' vntCustomer = WS2.Range(WS2.Cells(1, 1), WS2.Cells(7334, 2)).Value
With Worksheets("顧客リスト").Cells(1, 1)
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
vntCustomer = .Resize(lngRows, 2).Value
End With
Set rngSales = Worksheets("売上データ").Cells(1, 1)
' vntSales = WS1.Range(WS1.Cells(1, 1), WS1.Cells(20703, 2)).Value
With rngSales
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
vntSales = .Resize(lngRows).Value
ReDim vntResult(1 To lngRows, 1 To 1)
End With
For i = 1 To lngRows
' ans = Application.WorksheetFunction.VLookup(vntSales(i, 1), vntCustomer, 2, False)
vntResult(i, 1) = BinarySearch(vntSales(i, 1), vntCustomer)
Next i
Application.ScreenUpdating = False
rngSales.Offset(, 1).Resize(lngRows).Value = vntResult
Application.ScreenUpdating = True
Set rngSales = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
Private Function BinarySearch(ByVal vntKey As Variant, _
ByVal vntScope As Variant) As Variant
' 二進探索
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
lngLow = LBound(vntScope, 1)
lngHigh = UBound(vntScope, 1)
Do While lngLow <= lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
Select Case vntScope(lngMiddle, 1)
Case Is < vntKey
lngLow = lngMiddle + 1
Case Is > vntKey
lngHigh = lngMiddle - 1
Case Is = vntKey
lngLow = lngMiddle + 1
lngHigh = lngMiddle - 1
End Select
Loop
If lngLow = lngHigh + 2 Then
BinarySearch = vntScope(lngMiddle, 2)
Else
BinarySearch = Empty
End If
End Function
|
|
Hirofumi
- 05/9/3(土) 15:57 -
