Dynamic AutoShape
Hi Mut,
this worked for me...
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column 2 Then Exit Sub
Dim iRowCount As Long
Dim Shp As Shape
Dim BooDone As Boolean
Dim iLastRow As Long
iLastRow = Range("A:A").Rows.Count - _
Range(Cells(Range("A:A").Rows.Count, 1), _
Cells(Range("A:A").Rows.Count, 1).End(xlUp)).Rows.Count + 1
For iRowCount = 1 To iLastRow
For Each Shp In Me.Shapes
If Shp.Top = Cells(iRowCount, 1).Top _
And Shp.Top <= Cells(iRowCount, 1).Top _
+ Cells(iRowCount, 1).RowHeight _
And Shp.Left < Columns(4).Left _
And Shp.Left = Columns(3).Left Then
Select Case Cells(iRowCount, 2).Value - _
Cells(iRowCount, 1).Value
Case Is 0
Shp.Rotation = 315
Case Is < 0
Shp.Rotation = 45
Case 0
Shp.Rotation = 0
End Select
BooDone = True
End If
If BooDone Then Exit For
Next Shp
BooDone = False
Next iRowCount
End Sub
It's an event procedure that is triggered when ever the worksheet with
your shapes changes.
If the change occurs in any column other than columns A or B then the
procedure is exited and nothing happens. When the user changes any cell
values in columns A or B then the code adjusts each shapes rotation
depending on the A and B values in the shapes row.
The code only affects shapes in column C.
The code must be pasted into the code module of the sheet with the
shapes (sheet 1).
Copy the code. Right click the sheet tab. Select "View code" from the
contextual menu that pops up then paste the code in place.
Ken Johnson
|