PDA

View Full Version : Solved: Excel 2003 - Need to change the value in cell that contains a specific autoshape



frank_m
12-13-2010, 06:09 PM
With the code below I am creating an AutoShapeCross and positioning it relative to the active cell and row.

Later I may be selecting a different cell in a different row, but need the macro that is assigned to the AutoShapeCross to when clicked change the value in the cell where the Cross is positioned. - The string value I want entered into the cell is "Complete".
I believe it is possible using the top or left position of the Cross, but I have no idea how to code it.

The Cross is always named "MyShapeCross"

Thank you much for some insight.
Sub Macro1()

Dim TopPos As Integer
Dim LeftPos As Integer
Dim intWidth As Integer
Dim intHeight As Integer

TopPos = ActiveCell.Offset(0, 10 - ActiveCell.Column).Top
intWidth = 18
intHeight = 18
LeftPos = ActiveCell.Offset(0, 10 - ActiveCell.Column).Left

Dim shp As Shape

For Each shp In ActiveSheet.Shapes
If shp.AutoShapeType = msoShapeCross Then
shp.Delete
End If
Next shp

DoEvents

Set shp = ThisWorkbook.Worksheets("Sheet1").Shapes.AddShape(msoShapeCross, _
LeftPos, TopPos, intWidth, intHeight)

With shp
.Name = "MyShapeCross"
.Placement = xlMoveAndSize
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 12
.OnAction = "ChangeValue_inCellRelativeTo_Cross"
End With

End Sub

frank_m
12-13-2010, 07:03 PM
I got it worked out :) - Thanks so much to anyone that may have looked into this, I really appreciate you guys volunteeering your time and expertise.
Sub ChangeValue_inCellRelativeToShapeCross()

ActiveSheet.Shapes("MyShapeCross").TopLeftCell.Value = "Complete"

End Sub And added the command ActiveCell.RowHeight = 18 to the beginning of the create Cross shape macro below.
Sub Macro1()

Dim TopPos As Integer
Dim LeftPos As Integer
Dim intWidth As Integer
Dim intHeight As Integer

ActiveCell.RowHeight = 18 '<-Added this

LeftPos = ActiveCell.Offset(0, 10 - ActiveCell.Column).Left
TopPos = ActiveCell.Offset(0, 10 - ActiveCell.Column).Top
intWidth = 18
intHeight = 18


Dim shp As Shape

For Each shp In ActiveSheet.Shapes
If shp.AutoShapeType = msoShapeCross Then
shp.Delete
End If
Next shp

DoEvents

Set shp = ThisWorkbook.Worksheets("Sheet1").Shapes.AddShape(msoShapeCross, _
LeftPos, TopPos, intWidth, intHeight)

With shp
.Name = "MyShapeCross"
.Placement = xlMoveAndSize
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 12
.OnAction = "ChangeValue_inCellRelativeToShapeCross"
End With

End Sub