VBA CODE, THE RETURN IMAGE SHOULD BE ON THE RIGHT CELL

[PETERPIEPER]

HI. IVE FOUND THIS CODE. I WANT TO KNOW HOW I CAN MAKE THE RETURN IMAGE PLACE ON THE RIGHT CELL INSTEAD OF BELOW CELL .

 Option Explicit
   
    'More about Worksheet_Change at the below link
    '[URL='https://stackoverflow.com/questions/13860894/why-ms-excel-crashes-and-closes-during-worksheet-change-sub-procedure/13861640#13861640']Why MS Excel crashes and closes during Worksheet_Change Sub procedure?[/URL]
   
    Private Sub Worksheet_Change(ByVal Target As Range)
    '~~> Check if multiple cells were changed
    If Target.Cells.CountLarge > 1 Then Exit Sub
   
    On Error GoTo Whoa
   
    Application.EnableEvents = False
                   
    If Not Intersect(Target, Range("B4:F8")) Is Nothing Then
        Dim wsPic As Worksheet
        Dim pic As Shape, txtShp As Shape, shp As Shape
        Dim addr As String
        Dim aCell As Range
       
        '~~> Identify the shape below the changed cell
        For Each shp In ActiveSheet.Shapes
            If shp.TopLeftCell.Address = Target.Offset(1).Address Then
                Set txtShp = shp
                Exit For
            End If
        Next shp

        Set wsPic = ThisWorkbook.Sheets("PIC")
       
        '~~> Find the text in the PIC sheet
        Set aCell = wsPic.Columns(1).Find(What:=Target.Value2, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
       
        '~~> Identify the shape
        If Not aCell Is Nothing Then
            For Each shp In wsPic.Shapes
                If shp.TopLeftCell.Address = aCell.Offset(, 1).Address Then
                    Set pic = shp
                    addr = aCell.Offset(, 1).Address
                    Exit For
                End If
            Next shp
        End If
       
        '~~> Add the formula to show the image
        If Not pic Is Nothing And Not txtShp Is Nothing Then
            txtShp.Select '<~~ Required to insert the formula
            Selection.Formula = "=PIC!" & addr
        Else
            txtShp.Select
            Selection.Formula = "=PIC!$B$2"
        End If
        Target.Select '<~~ Remove focus from the shape
    End If
   
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

 

[Anthony47]

You should modify the line If shp.TopLeftCell.Address = Target.Offset(1).Address Then to

If shp.TopLeftCell.Address = Target.Offset(0,1).Address Then

Bye