Thread: 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

Not completely straightforward as you need to know what the shape was
previously rotated to. Have you ried recording a macro and incorporating
into either a Worksheet change event (if your cells are values) or the
calculate event if formulas.

Unless you particularly need the Autoshape arrows why not use Wingdings
arrows and a simple formula.

Sub WingDingsArrows()

Range("G1:G26").Font.Name = "Wingdings"
For i = 223 To 248

Cells(i - 222, 5) = i
Cells(i - 222, 6) = Chr(i)
Cells(i - 222, 7) = Chr(i)
Next

End Sub

Sub test()

Range("A1:b10").Formula = "=INT(RAND()*10)"
With Range("C1")
.Font.Name = "Wingdings"
.Formula = "=IF(A1>B1,""ò"",IF(A1<B1,""ñ"",""ó""))"
.AutoFill Range("C1:C10")
End With

End Sub

In case symbols in the above formula messes up html code replace "a", "b" &
"c" in following with chr(241) to 243 respectively. Or in cells hold Alt and
type 0241.

Regards,
Peter T

"Mut" <Mut.226cqm_1138165802.3299@excelforum-nospam.com> wrote in message
news:Mut.226cqm_1138165802.3299@excelforum-nospam.com...
>
> Dear all,
> I have sheet1 that contains Data in column A and B.
>
> A B
> 5 3
> 7 10
> 4 4
>
> In column C, I create Autoshape-BlockArrow-RightArrow that indicate
> flow data in a row.
>
> If B is greater than A, so Right Arrow could be rotate 315 degree.
> If B is less than A, so Right Arrow could be rotate 45 degree.
> If B is equal to A, so Right Arrow not rotated.
>
> I need VBA code doing this 'dynamic right arrow'...
> Thanks for your help...
>
> Regards,
> Mut
>
>
> --
> Mut
> ------------------------------------------------------------------------
> Mut's Profile:
http://www.excelforum.com/member.php...o&userid=30633
> View this thread: http://www.excelforum.com/showthread...hreadid=504768
>

Hi Mut,
my previous reply works but I went of the rails a bit when I was
determining the last used row in column A. The code below works the
same, I've just replaced the complicated code with a simpler version...

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
For iRowCount = 1 To Range("A" & Range("A:A").Rows.Count) _
..End(xlUp).Row
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

Ken Johnson

Dear all..

Thanks for your help, Ken Johnson and Peter T. All Your code work properly. Thanks!!

Then.. I'm still confusing when my data and right-arrow in a row.
e. g

Row 1 5 7 4
Row 2 3 10 4
Row 3 (Right-Arrow; 315 degree if Row2 is greater than Row1...etc.)

Thanks,
Mut

Hi Mut,
For the new situation try this code pasted into the worksheet's code
module...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 2 Then Exit Sub
Dim iColumnCount As Long
Dim Shp As Shape
Dim BooDone As Boolean
For iColumnCount = 1 To Cells(1, Range("1:1"). _
Columns.Count).End(xlToLeft).Column
For Each Shp In Me.Shapes
If Shp.Left >= Cells(1, iColumnCount).Left _
And Shp.Left <= Cells(1, iColumnCount).Left _
+ Cells(1, iColumnCount).Width _
And Shp.Top < Rows(4).Top _
And Shp.Top >= Rows(3).Top Then
Select Case Cells(2, iColumnCount).Value - _
Cells(1, iColumnCount).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 iColumnCount
End Sub

Ken Johnson

Woww!!! Thanks!
It works!

Regards,
Mut

Hi Mut,
Once again, you're welcome, and thanks for the feedback.
Ken Johnson