| |
▼UO3 さん：
>わたしも、領域と見なしてIntersectで判断することを一瞬考えたのですが
>もし、数値が200万といったものだと、行数をオーバしてしまうということと
>Sheet2の上限数値がSheet1の下限数値と同じなら、重なってはいないと見なすという
>条件があって、ギブアップしました。
単純に 1セルだけ重なってるだけだったら、「ハズレ」と判定
と単純化しましたが、やっぱり 却下ですかねェ
以下はこの考えは変えず、
A列が chr1〜chr3 などのばあいです。
Sub test2()
Dim dic As Object
Dim i As Long, n As Long
Dim r As Range, t As Range, c As Range
Dim v, ID
Set dic = CreateObject("Scripting.Dictionary")
Set r = Worksheets("Sheet1").Cells(1).CurrentRegion
v = Intersect(r, r.Offset(1)).Value
With Excel.Range("A1")
For i = 1 To UBound(v)
If Not dic.Exists(v(i, 1)) Then
Set dic(v(i, 1)) = _
CreateObject("Scripting.Dictionary")
End If
Set dic(v(i, 1))(v(i, 4)) = Excel.Range( _
.Offset(v(i, 2)), .Offset(v(i, 3)))
Next
Set r = Worksheets("Sheet2").Cells(1).CurrentRegion
v = Intersect(r, r.Offset(1)).Value
For i = 1 To UBound(v) 'Sheet2 2行目から
v(i, 4) = Empty
If dic.Exists(v(i, 1)) Then
Set t = Excel.Range( _
.Offset(v(i, 2)), .Offset(v(i, 3)))
v(i, 4) = "ハズレ"
For Each ID In dic(v(i, 1)).Keys()
Set c = Nothing
On Error Resume Next
Set c = Intersect(dic(v(i, 1))(ID), t)
On Error GoTo 0
If Not c Is Nothing Then
If c.Count > 1 Then v(i, 4) = ID
Exit For
End If
Next
End If
Next
End With
r.Item(2, 1).Resize(UBound(v), 4).Value = v
End Sub
|
|
kanabun
- 12/8/16(木) 0:37 -
