Показ Listbox при выделении ячейки, а не строки

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Shp As Object
    If Not Intersect(Target, Range("I5:I1000")) Is Nothing Then
        With Me.ListBox1
            .Top = Target.Offset(0, 1).Top
            .Left = Target.Offset(0, 1).Left
            .Visible = True
        End With
        Set Shp = ActiveSheet.Shapes("Button 7").DrawingObject
        With Shp
            .Top = ActiveCell.Top
            .Left = ActiveCell.Offset(0, 11).Left
            .Visible = True
        End With
    Else
        Me.ListBox1.Visible = False
        ActiveSheet.Shapes.Range(Array("Button 7")).Visible = False
    End If
End Sub

Target(1).Offset(0, 1)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range
    Set r = Intersect(Target, Range("I5:I1000"))
    If Not r Is Nothing Then
        With ListBox1
             .Top = r.Top
             .Left = r(1, 2).Left
             .Visible = True
        End With
        With Buttons("Button 7")
             .Top = r.Top
             .Left = r(1, 12).Left
             .Visible = True
        End With
    Else
        ListBox1.Visible = False
        Buttons("Button 7").Visible = False
    End If
End Sub