| |
▼T.K さん：
先ほどの判定図（4ケース）より以下のように考えてみました。
Case[1]
a1━━━━━━━━a2
b1────b2
Case[2]
a1━━━━━━━━a2
b1─────b2
Case[3]
a1━━━━━━━━a2
b1──────b2
Case[4]
a1━━━━━━━━a2
b1────────────b2
（判別方法）
b1 が a1 より下のとき
b2 が a1 より大きい [1]と [4] をカバー
b1 が a1 より大きいとき、
b1 が a2 より小さい [2]と [3] をカバー
とりあえず、以上、2種類です。
Sub test3()
Dim dic As Object
Dim i As Long, n As Long
Dim r As Range
Dim v, ID
Set dic = CreateObject("Scripting.Dictionary")
Set r = Worksheets("Sheet1").Cells(1).CurrentRegion
v = Intersect(r, r.Offset(1)).Value
For i = 1 To UBound(v)
If Not dic.Exists(v(i, 1)) Then
Set dic(v(i, 1)) = _
CreateObject("Scripting.Dictionary")
End If
dic(v(i, 1))(v(i, 4)) = Array(v(i, 2), v(i, 3))
Next
Dim a1, a2
Dim b1, b2
Dim vv
Set r = Worksheets("Sheet2").Cells(1).CurrentRegion
With Intersect(r, r.Offset(1))
v = .Resize(, 3).Value
vv = .Columns(4).Cells.Value
End With
For i = 1 To UBound(v) 'Sheet2 2行目から
vv(i, 1) = Empty
If dic.Exists(v(i, 1)) Then
a1 = v(i, 2)
a2 = v(i, 3)
vv(i, 1) = "ハズレ"
For Each ID In dic(v(i, 1)).Keys()
b1 = dic(v(i, 1))(ID)(0)
b2 = dic(v(i, 1))(ID)(1)
Select Case b1
Case Is < a1
If b2 > a1 Then
vv(i, 1) = ID
Exit For
End If
Case Is > a1
If b1 < a2 Then
vv(i, 1) = ID
Exit For
End If
End Select
Next
End If
Next
r.Item(2, 4).Resize(UBound(vv)).Value = vv
End Sub
|
|
kanabun
- 12/8/28(火) 10:38 -
