| |
各シートのレイアウトは、以下の様に成っているとします
**現在シート**
A B
1 コード 商品名
2 1
3 5
4 3
5 4
**参照シート**
A B
1 コード 商品名
2 1 りんご
3 2 ばなな
4 3 なし
5 4 すいか
6 5 ぶどう
7 6 もも
参照シートは、コードでソートされている物とします
以下を標準モジュールに記述して下さい
Option Explicit
Option Compare Text
Public Sub DataSearch()
Const lngRowEnd As Long = 65536
Dim i As Long
Dim vntData As Variant
Dim vntDataFile As Variant
Dim blnExist As Boolean
Dim strName As String
Dim vntResult As Variant
Dim vntKeys As Variant
Dim rngKyes As Range
'"参照シート"の有るファイルを取得
If Not GetReadFile(vntDataFile, _
ThisWorkbook.Path, False) Then
Exit Sub
End If
'画面更新の停止
Application.ScreenUpdating = False
strName = GetFileName(vntDataFile)
With Workbooks
For i = 1 To .Count
If .Item(i).Name = strName Then
blnExist = True
Exit For
End If
Next i
If blnExist Then
.Item(strName).Activate
Else
'"参照シート"の有るファイルをOpen
.Open (vntDataFile)
End If
End With
'データを取得
With Workbooks(strName).Worksheets("参照シート")
vntData = Range(.Cells(2, "A"), _
.Cells(lngRowEnd, "B").End(xlUp)).Value
End With
'入力ファイルをClose
Workbooks(strName).Close
'コードの有る範囲を設定
With ThisWorkbook.Worksheets("現在シート")
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) = BinarySearch(vntKeys(i, 1), vntData)
Next i
'結果を出力
With rngKyes
.Offset(, 1).Resize(.Rows.Count).Value = vntResult
End With
Set rngKyes = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function BinarySearch(vntKey As Variant, _
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
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "Excel File (*.xls),*.xls," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
Private Function GetFileName(ByVal strName As String) As String
' ファイル名をPathから分離
Dim i As Long
Dim lngPos As Long
i = 0
lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
Do Until lngPos = 0
i = lngPos
lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
Loop
GetFileName = Mid(strName, i + 1)
End Function
|
|
Hirofumi
- 04/7/10(土) 0:42 -
