How do I change a cell's value based on the movement of a shape (or textbox, or picture) in exc-CodePudding

I am not trained with coding in any way, but have in the past managed to use codes I found online as part of excel or access using macros or buttons and things. This is a bit harder to figure out if it is even possible.

I have been trying to figure out some way in excel to reference a textbox or shape position relative to a cell (e.g. Picture one is in Cell A1 so somewhere the link between the two is made).

Practical application for this would be: I have designated class areas e.g. Class A (whose area is A1:A6) and Class B (whose area is B1:B6) and I have a picture(or shape/text box) or something for each individual learner. If I place that learners picture within cell range A1:A6, the picture should somehow link with the class.

I have found a few pieces of code online that I have tried independently and they work (apologies for not referencing where/who I found them from), and I think if I could somehow combine them I might be able to do what I need.

The first is programming a button to look at all the shapes on the active sheet and list their names somewhere, there were two pieces I've found:

Private Sub CommandButton1_Click()
Dim x&
With Sheets("sheet1")
For x = 1 To .Shapes.Count
Sheets("sheet2").Cells(x, 1).Value = .Shapes(x).Name
Next
End With
End Sub

Private Sub CommandButton3_Click()
Dim iCount As Integer
For iCount = 1 To ActiveSheet.Shapes.Count
Cells(iCount, 1).Value = ActiveSheet.Shapes(iCount).Name
Next iCount
End Sub

I've also found code to select shapes found within certain cell ranges:

Private Sub CommandButton5_Click()
Dim shp As Shape
Dim r As Range

Set r = Range("A1:A3")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shp.Select Replace:=False
Next shp
End Sub

And another for creating an reference to all shapes within an array of cells (as I understand it)

Sub Shapepicker()

Dim s As Shape, sr As ShapeRange
    Dim Arr() As Variant
    Set mycell = Range("A:A")
    rrow = "A1"

i = 1
For Each s In ActiveSheet.Shapes
    If s.TopLeftCell = rrow Then
        ReDim Preserve Arr(1 To i)
        Arr(i) = s.Name
        i = i   1
    End If
Next s

Set sr = ActiveSheet.Shapes.Range(Arr)

End Sub

I've tried frankensteining pieces of the codes together, to place the names of shapes found within a specific range of cells somewhere, but haven't been able to make it work with my limited knowledge.

Any help would be appreciated.

CodePudding user response：

Not sure what output you want exactly, but with 2 classes this will put the shapes in one class in column A and the others in column B.

Private Sub CommandButton1_Click()

Dim shp As Shape
Dim r1 As Range, r2 As Range

Set r1 = Range("C3:F5") 'class 1
Set r2 = Range("G12:H15") 'class 2

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r1) Is Nothing Then Cells(Rows.Count, 1).End(xlUp)(2).Value = shp.Name
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r2) Is Nothing Then Cells(Rows.Count, 2).End(xlUp)(2).Value = shp.Name
Next shp

End Sub