|
>この現在使用しているシートのみでなく、
>別シートを次々処理したく、
と言う事なら、発想を変えて、こんなのでも言いと思いますが?
今度は、以下のコードを「**参照シート**」の有るBookの標準モジュールに記述して下さい
まず、「**参照シート**」の有るBookを開きます
次に、処理したいBookを開き、処理したいシートをActiveにします
「DataSearch2」を実行します
処理したBookを閉じ、次に処理したいBookを開き同様にします
Option Explicit
Public Sub DataSearch2()
Const lngRowEnd As Long = 65536
Dim i As Long
Dim rngData As Range
Dim vntResult As Variant
Dim vntKeys As Variant
Dim rngKyes As Range
'画面更新の停止
Application.ScreenUpdating = False
'データ範囲を取得
With ThisWorkbook.Worksheets("参照シート")
Set rngData = Range(.Cells(2, "A"), _
.Cells(lngRowEnd, "A").End(xlUp))
End With
'コードの有る範囲を設定
With ActiveSheet
Set rngKyes = Range(.Cells(2, "A"), _
.Cells(lngRowEnd, "A").End(xlUp))
End With
'コードを配列に取得
vntKeys = rngKyes.Value
'結果用配列を確保
ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 1)
'コードの先頭から終りまで繰り返し
For i = 1 To UBound(vntKeys, 1)
'コードを探索
vntResult(i, 1) = RowSearchBin(vntKeys(i, 1), rngData)
Next i
'結果を出力
With rngKyes
.Offset(, 1).Resize(.Rows.Count).Value = vntResult
End With
Set rngKyes = Nothing
Set rngData = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function RowSearchBin(vntKey As Variant, _
rngScope As Range) As Variant
Dim vntFind As Variant
Dim lngDataTop As Long
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearchBin = rngScope(vntFind, 2).Value
End If
End If
End Function
|
|