Text box need to appear between AB/FG/LM/PQ...ETC

[bhandari]

1)Text boxes are starting from AB (Vertical Rectangle shape) ..this shape need to appear at every 4 columns automatically until AZ.
start from AB/FG/LM/PQ---ETC
only boxes need to be appear

Please find the LINK below
https://drive.google.com/open?id=1aZrjJeQQQO13bxmGUrY3DBtAshoxJIX6

Can i get macro for this

 

[sunnyland]

I believe this may do the trick.
For this code to work you will have to rename sheet and initial shape name

Option Explicit

Sub populatearrow()
Dim shapi As Shape
'replace Sheet2 by the name of the sheet and Arrow2 by the name of the initial shape that you want to copy
Set shapi = Sheets("Sheet2").Shapes("Arrow2")
Dim shap As Shape
Dim x
Dim position
position = shapi.Left
For x = 2 To 11
'replace Sheet2 by the name of the sheet
Set shap = Sheets("Sheet2").Shapes.AddShape(shapi.AutoShapeType, position + Sheets("Sheet2").Cells(1, 29).Width * 5, shapi.Top, shapi.Width, shapi.Height)
shap.Visible = True
position = shap.Left
Set shap = Nothing
Next
Set shapi = Nothing
End Sub

 

[sunnyland]

sorry saw a typo afterwards
It is not 29 but 2 as code will use the column 2 to calculate the left position of the shapes
Set shap = Sheets("Sheet2").Shapes.AddShape(shapi.AutoShapeType, position + Sheets("Sheet2").Cells(1, 2).Width * 5, shapi.Top, shapi.Width, shapi.Height)

 

[bhandari]

Tnx it's working fine. IAM looking for little more changes in this program. Can we do if condition with cell value(A1=1,A2=google..etc).whatever the vertical boxes are appearing on screen untill AZ..I like to insert text in it. is it possible sir?

 

[sunnyland]

What do you mean:
*each shape will have a different text based on some cells value [each shape will have different text]
*all shapes will take the same text based on some cells value [all shapes will have the same text]

 

[bhandari]

iam looking for this
*each shape will have a different text based on some cells value [each shape will have different text]

 

[sunnyland]

You may want to try this to see if it works for you.

Sub populatearrow()
Dim shapi As Shape
'replace Sheet2 by the name of the sheet and Arrow2 by the name of the initial shape that you want to copy
Set shapi = Sheets("Sheet2").Shapes("Arrow2")
Dim shap As Shape
Dim x
Dim position
position = shapi.Left
For x = 2 To 11
'replace Sheet2 by the name of the sheet
Set shap = Sheets("Sheet2").Shapes.AddShape(shapi.AutoShapeType, position + Sheets("Sheet2").Cells(1, 29).Width * 5, shapi.Top, shapi.Width, shapi.Height)
' rename the shape so it can be identified later
shap.Name = "myarrow" & x
'run the changeText sub to name by testing conditions
changeText shap
shap.Visible = True
position = shap.Left
Set shap = Nothing
Next
Set shapi = Nothing
End Sub


Sub changeText(thearrow As Shape)
With Sheets("sheet2")
Select Case thearrow.Name
'initial Arrow
Case "Arrow2"
'ie: row1, column1 and row1,column2
If .Cells(1, 1) = 1 And .Cells(1, 2) = "Google" Then
thearrow.TextFrame2.TextRange.Text = "1 and google"
End If
'other arrow
Case "myarrow2"
If .Cells(1, 6) = 2 And .Cells(1, 7) = "Navigator" Then
thearrow.TextFrame2.TextRange.Text = "2 and Navigator"
End If
Case "myarrow3"
If .Cells(1, 11) = 3 And .Cells(1, 12) = "Space" Then
thearrow.TextFrame2.TextRange.Text = "3 and Space"
End If
Case "myarrow4"
If .Cells(1, 16) = 4 And .Cells(1, 17) = "Skype" Then
thearrow.TextFrame2.TextRange.Text = "4 and Skype"
End If

'to myarrow11
Case "myarrow11"
End Select
End With
End Sub

 

[bhandari]

1.can we set the text box style,The existed shape with the name of "Arrow2", which is different from second shape style,can you please fix it.

Please find the Link below

2.How to continue the next row with Text box,i want to continue to next row from 10th row(Evrey 10 rows
untill 50th row)
Please find the Link below

3.how to add multiple shapes,i want to add multiple shapes in random positions for that i have to give Box positions as a input instead of editing in macro.

Can we do it by inputbox or cells
whatever which is possible without macros

Can you please help me with this to finish it..

i am doing all this steps manually..its taking lot of time

Thank you for your Helping

i hope your macro will help me


https://drive.google.com/open?id=1c80WKZdQfOMLTfWK2_y0wX0HifCf9CyW

https://drive.google.com/open?id=1bOTygdXOnhza9Wt-TdGFqZynuS9CSaOn

 

[sunnyland]

Hello,
Sorry about delay in answering as busy at work and getting ready for a long holiday. Not sure I can help you more at this time as don't have the necessary time to think about your problem.

However the last thing I could do for you at this point is provided a quick code to generate shapes from a data table , you can take a look at the file I posted. The code will add shapes according to table data [including text labels]. The shapes are generated randomly but you can choose the ones you need. Also there are the fields left, top, width and height to be entered as centimeters on the sheet input.

Have a play and see if this could be a better way to go about it.

I have uploaded the file to OneDrive. Download it to your drive and run the macro createshapes. It will add shapes to the Results Sheet.

The link is
https://1drv.ms/x/s!Ana307X99Y1KhT4E5vPimmAZDN6L

The code used is:

Sub createshapes()
Dim tabli As Range
Set tabli = Sheet1.ListObjects("table1").DataBodyRange
Dim shapi As Shape
For x = 1 To tabli.Rows.Count
Set shapi = Sheet2.Shapes.AddShape(tabli.Cells(x, 6), Application.CentimetersToPoints(tabli.Cells(x, 2)), Application.CentimetersToPoints(tabli.Cells(x, 3)), Application.CentimetersToPoints(tabli.Cells(x, 4)), Application.CentimetersToPoints(tabli.Cells(x, 5)))
shapi.TextFrame2.TextRange.Text = tabli.Cells(x, 1)
shapi.Visible = msoCTrue
Set shapi = Nothing
Next
End Sub

Sorry if I am not able to provide assistance any longer at this time.