| |
リソース的には不利ですが、Findで探すより速いかな？
上手くいかなかったらゴメン
Public Sub Test1()
Dim i As Long
Dim j As Long
Dim vntRefe As Variant
Dim lngRefCount As Long
Dim lngRefPos As Long
Dim vntData As Variant
Dim lngDataCount As Long
Dim wksData As Worksheet
Dim lngDataTop As Long
'参照するデータの取得
With Worksheets("Sheet1")
'２行目から
vntRefe = Range(.Cells(2, 1), _
.Cells(65536, 2).End(xlUp)).Value
End With
'データ数の取得
lngRefCount = UBound(vntRefe, 1)
'データをソート
ShellSort vntRefe
'探索するデータのシート
Set wksData = Worksheets("Sheet2")
'データの先頭を２行目とする
lngDataTop = 2
With wksData
'探索するデータを取得
vntData = Range(.Cells(lngDataTop, 1), _
.Cells(65536, 1).End(xlUp)).Value
End With
'探索データ数の取得
lngDataCount = UBound(vntData, 1)
'配列を拡張
ReDim Preserve vntData(1 To lngDataCount, 1 To 2)
'探索データに行位置を代入
For i = 1 To lngDataCount
vntData(i, 2) = i + lngDataTop - 1
Next i
'探索データをソート
ShellSort vntData
'データの探索と書き込み
With wksData
'参照位置の初期値
lngRefPos = 1
'探索データを１つづつ取り出す
For i = 1 To lngDataCount
'探索先のデータが無くなるまで繰り返し
Do Until lngRefPos > lngRefCount
'もし、探索値が参照値より等しいか大きいなら
If vntData(i, 1) <= vntRefe(lngRefPos, 1) Then
'もし、探索値が参照値より等しいなら
If vntData(i, 1) = vntRefe(lngRefPos, 1) Then
'セルに代入
.Cells(vntData(i, 2), 2).Value _
= vntRefe(lngRefPos, 2)
End If
'Doを抜ける
Exit Do
End If
'参照位置を更新
lngRefPos = lngRefPos + 1
Loop
Next i
End With
Set wksData = Nothing
End Sub
Private Sub ShellSort(vntList As Variant)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim vntTmp(1) As Variant
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(vntList, 1)
lngEnd = UBound(vntList, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap <= 0
For i = lngGap + lngTop To lngEnd
vntTmp(0) = vntList(i, 1)
vntTmp(1) = vntList(i, 2)
For j = i To lngGap + lngTop Step -lngGap
If vntList(j - lngGap, 1) <= vntTmp(0) Then
Exit For
End If
vntList(j, 1) = vntList(j - lngGap, 1)
vntList(j, 2) = vntList(j - lngGap, 2)
Next j
vntList(j, 1) = vntTmp(0)
vntList(j, 2) = vntTmp(1)
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
Hirofumi
- 03/7/12(土) 8:46 -
