VBA to insert shape

[saravanan1981]

Hi,
I have below sample code which I have pasted in Sheet in View Code Window.

Please Login or Register  to view this content.

The same thing I need in VBA mode with below Changes

In attached file, in sheet "Data" in column F there are 3 criteria. "At Par", "High" and "Low"

In sheet "shapesapplicable", I have given applicable shapes against 3 Criteria.

In Sheet Data as per the selection in from down list in Column F, the shapes to be changed in column E (heading Shapes).

Few examples in given in sheet Data.

All shapes to be sdjusted in middle of the cell.

[Marc L]

According to your attachment a starter demonstration (edit v2) :

Private Sub Worksheet_Change(ByVal Target As Range) 
             Dim Pic As Shape, Sh As Shape 
    If Target.Column = 6 And Target.CountLarge = 1 Then 
        For Each Pic In Sheet2.Shapes 
              If Pic.TopLeftCell.Offset(, -1).Value2 = Target.Value2 Then Exit For 
        Next 
          If Not Pic Is Nothing Then 
                Application.ScreenUpdating = False 
            For Each Sh In Me.Shapes 
                  If Sh.Type = msoAutoShape Then _ 
                  If Sh.TopLeftCell.Address = Target(1, 0).Address Then Sh.Delete: Set Sh = Nothing: Exit For 
            Next 
                 Pic.Copy 
                 Me.Paste Target(1, 0) 
            With Selection 
                .ShapeRange.LockAspectRatio = msoTrue 
                .Placement = xlMove 
             If .Width > .TopLeftCell.Width - 2 Then .Width = .TopLeftCell.Width - 2 
             If .Height > .TopLeftCell.Height - 2 Then .Height = .TopLeftCell.Height - 2 
                .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2 
                .Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2 
            End With 
                ActiveWindow.RangeSelection.Select 
                Application.ScreenUpdating = True 
                Set Pic = Nothing 
          End If 
    End If 
End Sub  

Do you like it ? So thanks to click on bottom left star icon « ★ Add Reputation » !

[Greg M]

Hi there,

I may have misunderstood your requirements completely, but see if the attached workbook does the sort of thing you're looking for.

It uses the following code in the VBA CodeModule for the data worksheet:

Please Login or Register  to view this content.

The highlighted values may be altered to suit your requirements.

Changing a value in the "Levels" column will cause the appropriate Arrow Shape to appear in the "Shapes" column.


Hope this helps - please let me know how you get on.

Regards,

Greg M




NOTE TO ADMINISTRATORS:

Inserting the "End Select" statement (highlighted above) without a space character at the end caused the Sucuri Website Firewall message to appear and prevented the message from being posted - it took me a LONG time to determine the problem.

[saravanan1981]

Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....

[saravanan1981]

Marc,

Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....Superb .....

Thanks a ton

[saravanan1981]

Greg,
Thank you for your help. Code is not picking shapes as desired.

[saravanan1981]

Hi Marc,
Need one more help. It is possible to accommodate below mentioned task in above code?

1. If any row deleted in between, then the shape also should get deleted.
2. Row height and column width to be set/refreshed automatically as mentioned below after the selection any one cell in column F. Means If select any status from any of the cell in column “F”, then all the rows height, column with and shapes size should get refreshed.

a. Row No.1. (Heading) = Fixed Row Height = 27.6 (With format of middle allign and centre align)
b. Column 1 (A) = Column width = 4.11 (With format of middle allign and centre align)
c. Column 2 (B) = Column width = 37.78 (With format of middle allign and align left from 2nd row onwards)
d. Column 3 (C) = Column width = 57.78 (With format of middle allign and centre align from 2nd row onwards)
e. Column 4 (D) = Column width = 57.78 (With format of middle allign and centre align from 2nd row onwards)
f. Column 5 (E) = Column width = 10.11
g. Column 6 (F) = Column width = 6.33

[Greg M]

Hi again,

Thanks for your feedback - told you I'd probably misunderstood your requirements anyway

Regards,

Greg M

[Marc L]

According to your last attachment, my code is not the best when the arrows are in the same worksheet.
In this case I prefer to rename the source arrows shapes like Greg did within its attachment.
I prefer a separate worksheet like your initial attachment …

1. If any row deleted in between, then the shape also should get deleted.

As it depends how the row is deleted : if manually, you must delete the shape before …

2. Row height and column width to be set/refreshed automatically as mentioned below after the selection any one cell in column F. Means If select any status from any of the cell in column “F”, then all the rows height, column with and shapes size should get refreshed.

It's a mess for existing shapes as they will not well follow the resize …
Better than this kind of event (IMO) is to have when necesary a procedure tool deleting all existing shapes from column E
then recreate them for each row according to the formatting so you need first to well format columns & rows …
This procedure well fit too your first point.


If any row can be deleted or inserted, the way to follow is like Gred did …

[Marc L]

Or a better way than copying shapes : signs via conditional formatting, automatic, no need any code …