Select the cell behind a shape

[tonywatsonhelp]

Hi everyone,
I would like to have a macro that when I click on any shape in sheet "Data1" it select the cell Behind it,
The page is set in such a way that every picture is within a single cell.

Please help if you can

Thanks

Tony

 

[DanteAmor]

Assign to each figure the macro "Sel_Cell"

Sub Sel_Cell()
    Dim wCell As Range, v As Variant
    
    v = Application.Caller
    wtop = ActiveSheet.Shapes(v).Top
    For Each wCell In ActiveSheet.Range("A1", ActiveSheet.UsedRange.SpecialCells(11).Address)
        If Not Intersect(ActiveSheet.Shapes(v).TopLeftCell, wCell) Is Nothing And _
           Not Intersect(ActiveSheet.Shapes(v).BottomRightCell, wCell) Is Nothing Then
            wCell.Select
            Exit Sub
        End If
    Next
    MsgBox "The image is not within a single cell"
End Sub

 

[shg]

Assuming the point is not to validate the sheet design, why not just ...

Sub Sel_Cell()
  ActiveSheet.Shapes(Application.Caller).TopLeftCell.Select
End Sub

 

[Jeffrey Mahoney]

If you know that the shape will always be in that cell, no problem. But if you're asking for code to determine which cell the shape is in so you can select the cell, much harder.

This is some simple code I just created. I inserted a picture and made the corners attach to the cell corners of C2. Because the picture corners don't exactly match the cell corners, you have to fudge a little. Both of those subs were in the same standard module.

Sub Picture999_click()
  Dim Shp As Shape
  Set Shp = ActiveSheet.Shapes("Picture999")
  Call SelectCellByShape(Shp)
End Sub




Sub SelectCellByShape(Shp As Shape)
  Dim Cel As Range
  Dim L As Single
  Dim T As Single
  Dim PL As Single
  Dim PT As Single
  Dim Sht As Worksheet
  Dim C As Long
  Dim R As Long
  Dim Col As Long
  Dim Rw As Long
  
  Set Sht = ActiveSheet
  PL = Shp.Left
  PT = Shp.Top
  
  With Sht
    For Each Cel In .Range(.Cells(1, 1), .Cells(1, .Columns.Count))
      If Abs(Cel.Left - PL) < 0.001 Then
        Col = Cel.Column
        Exit For
      End If
    Next Cel
    
    For Each Cel In .Range(.Cells(1, 1), .Cells(.Rows.Count, 1))
      If Abs(Cel.Top - PT) < 0.001 Then
        Rw = Cel.Row
        Exit For
      End If
    Next Cel
  End With
  
  Sht.Cells(Rw, Col).Select
  
End Sub

 

[DanteAmor]

Assuming the point is not to validate the sheet design, why not just ...

Sub Sel_Cell()
  ActiveSheet.Shapes(Application.Caller).TopLeftCell.Select
End Sub

Awesome!

 

[tonywatsonhelp]

Thanks to all of you for your help,
they all worked great so I don't know who to thank the most so thank you to all of you.
Hope that's OK?
this was abig help
Thanks
Tony

 

[DanteAmor]

I'm glad to help you. I appreciate your kind comments.