| |
データが、数万行も有ると
最初のコードでは、えらく遅いと思います
因って、少し速くなる様にして見ました
ただし、今回のFunction DataReference2は、
ユーザー定義関数として使えませんので宜しく
Option Explicit
Public Sub Sample2()
' マクロとして使う場合
Dim i As Long
Dim lngPos As Long
Dim rngWeight As Range
Dim rngCode As Range
Dim lngRows As Long
Dim vntList As Variant
Dim vntData As Variant
Dim vntResult As Variant
'表の先頭セル位置（「品名コード/重量(g)」の書いて有るセル）
With Worksheets("Sheet2").Cells(1, "A")
'重量(g)の書いて有る列数を取得
lngPos = .End(xlToRight).Column - .Column
'重量(g)の書いて有る範囲を設定
Set rngWeight = .Offset(, 1).Resize(, lngPos)
'品名コードの有る行数を取得
lngPos = .End(xlDown).Row - .Row
'品名コードの有る範囲を設定
Set rngCode = .Offset(1).Resize(lngPos)
'表のデータ範囲を配列に取得
vntList = .Offset(1, 1).Resize(lngPos, rngWeight.Columns.Count).Value
End With
'結果表の先頭セル位置（「品名コード」の書いて有るセル）
With Worksheets("Sheet1").Cells(1, "A")
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 1 To 1)
'データ先頭から最終まで繰り返し
For i = 1 To lngRows
'データ1行分を配列に取得
vntData = .Offset(i).Resize(, 3).Value
'探索結果を出力用配列に代入
vntResult(i, 1) = DataReference2(vntData(1, 1), vntData(1, 3), _
rngCode, rngWeight, vntList)
Next i
'結果用配列を出力
.Offset(1, 3).Resize(lngRows).Value = vntResult
End With
Beep
MsgBox "処理が完了しました"
End Sub
Private Function DataReference2(vntCode As Variant, _
vntWeight As Variant, _
rngCode As Range, _
rngWeight As Range, _
vntList As Variant) As Variant
Dim lngFoundCode As Long
Dim lngFoundWeight As Long
Dim lngOver As Long
'商品コードの位置を探索
lngFoundCode = DataSearch(vntCode, rngCode)
'該当商品コードが無い場合
If lngFoundCode = 0 Then
DataReference2 = "該当商品コード無し"
Exit Function
End If
'重量(g)の位置を探索
lngFoundWeight = DataSearch(vntWeight, rngWeight, lngOver)
'該当重量が無い場合
If lngFoundWeight = 0 Then
If lngOver = 0 Then
DataReference2 = "該当重量無し"
Exit Function
Else
'Key値を超える最小値のある位置に
lngFoundWeight = lngOver
End If
End If
'発見した、行列位置の値を戻り値として返す
With rngCode
DataReference2 = vntList(lngFoundCode, lngFoundWeight)
End With
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long) As Long
Dim vntFind As Variant
If vntKey = "" Then
Exit Function
End If
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
DataSearch = vntFind
End If
'Key値を超える最小値のある行
If vntFind = rngScope.Count Then
lngOver = 0
Else
lngOver = vntFind + 1
End If
Else
lngOver = 1
End If
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
