| |
☆印が追加するコード
★印が変更するコードです
Option Explicit
Public Sub DataSearch()
Const lngRowEnd As Long = 65536
Dim i As Long
Static 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
Dim lngFound As Long '☆追加
'ファイルを指定する場合
vntDataFile = "C:\My Documents\参照シート.xls"
'画面更新の停止
Application.ScreenUpdating = False
'もし、参照用データが無いなら
If VarType(vntData) <> vbArray + vbVariant Then
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, "C").End(xlUp)).Value '★変更
End With
'入力ファイルをClose
Workbooks(strName).Close
End If
'コードの有る範囲を設定
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 2) '★変更
'コードの先頭から終りまで繰り返し
For i = 1 To UBound(vntKeys, 1)
'コードを探索
lngFound = BinarySearch(vntKeys(i, 1), vntData) '★変更
If lngFound <> -1 Then '☆追加
vntResult(i, 1) = vntData(lngFound, 2) '☆追加
vntResult(i, 2) = vntData(lngFound, 3) '☆追加
End If '☆追加
Next i
'結果を出力
With rngKyes
.Offset(, 1).Resize(UBound(vntResult, 1), _
UBound(vntResult, 2)).Value = vntResult '★変更
End With
Set rngKyes = Nothing
Application.ScreenUpdating = True
Beep
If MsgBox("処理が完了しました" & vbCrLf _
& "続けて処理を行いますか？", _
vbExclamation + vbYesNo + vbDefaultButton1, _
"配列の保持") = vbNo Then
vntData = Empty
End If
End Sub
Private Function BinarySearch(vntKey As Variant, _
vntScope As Variant) As Long '★変更
' 二進探索
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 = lngMiddle '★変更
Else
BinarySearch = -1 '★変更
End If
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/21(水) 21:04 -
