Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [D2:D10]) Is Nothing Then
       Cancel = True
       With Me.Shapes("List Box 2")
        .Top = Target.Offset(, 1).Top
        .Left = Target.Offset(, 1).Left
       End With
    End If
End Sub

Public iTarget As Range

Private Sub ListBox1_Change()
If Not iTarget Is Nothing Then
    With Me.ListBox1
        .Visible = False
        iTarget = .Value
    End With
End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [D2:D10]) Is Nothing And Target.Count = 1 Then
       Application.ScreenUpdating = False
       Cancel = True
       Set iTarget = Target
       With Me.ListBox1
        .Top = Target.Top
        .Left = Target.Left
        .Visible = True
       End With
    End If
Application.ScreenUpdating = True
End Sub