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

PETERPIEPER

New Member
Joined
Nov 12, 2020
Messages
1
Office Version
  1. 2019
Platform
  1. Windows
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 .
VBA Code:
 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


1605188297172.png
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,135
You should modify the line If shp.TopLeftCell.Address = Target.Offset(1).Address Then to
VBA Code:
If shp.TopLeftCell.Address = Target.Offset(0,1).Address Then
Bye
 

Watch MrExcel Video

Forum statistics

Threads
1,127,529
Messages
5,625,352
Members
416,096
Latest member
forevans

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top