Macro code help

[John Ashok]

Hi,


can you pl help me with a macro code for the below task in excel 2007.I am new to macros.


1.In Sheet1 I have 100's of Rectangular shapes each containing one text box containing Text(Single sentence with many words).each Rectangular shape is one below the other in order and each connected with a ARROW to next Rectangular shape.
2.I want Text of each Rectangular shape to be replaced with text from cells from Sheet2, Cell Range A1 to A100+(number of text cells are equal to no of rectangular shapes) retaining Text Formatting of Sheet2 text.
Pl help with complete code as I am very new to macros.

 

[RickXL]

Hi and welcome to the forum.

This should get you started. I tried it with three (and four) shapes. I have renamed my shapes to match the cell that the text will be in. So my shapes were called A1, A2 and A3. In Excel 2013 you can rename the shapes here: Home-->Editing-->Find & Select-->Selection Pane.

The macro loops round the shapes and adds the text and changes some of the font details.

The block of code at the start with the comments highlights the changes you may need to make if you use different worksheets, columns or number of shapes.

The code should be added to a new macro module. From the worksheet view:
Right Click a worksheet tab
Select: View code
On the new window select: Insert-->Module
Paste in the macro.
Make the changes to the commented area (Sheets, Column and Shapes)

To run the macro, make sure the cursor is somewhere in the code then hit F5. You could change this to be run from a button or even one of the shapes.

For instance, right click a shape, choose Assign Macro and select the macro name: xx.
Now when you click this shape the text will be updated.

Sub xx()
    Dim NumbeOfShapes As Long
    Dim TextColumn As String
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    NumbeOfShapes = 4               ' Change this number if necessary
    TextColumn = "A"                ' Change to match the text column
    Set ws1 = Worksheets("Sheet1")  ' Sheet name for shapes
    Set ws2 = Worksheets("Sheet2")  ' Sheet name for text
    
    For i = 1 To NumbeOfShapes
        With ws1.Shapes(TextColumn & i).TextFrame.Characters
            .Text = ws2.Range(TextColumn & i).Value
            .Font.Size = ws2.Range(TextColumn & i).Font.Size
            .Font.Name = ws2.Range(TextColumn & i).Font.Name
            .Font.Color = ws2.Range(TextColumn & i).Font.Color
        End With
    Next

End Sub

 

[John Ashok]

Hi RickXL,
Thanks a lot for your help and quick reply.I tried your code on 4 new boxes renaming them to A1,A2,A3,A4 as suggested by you.copying part It worked fine.
But I have a issue here.My shape names in my actual sheets starts with Rectangle1,Rectangle2,......Rectangle250.
It would be difficult to change shape names manually for so many of them.can you pl help to get this done through macro or any other way.
Also my Text cell has three words but all three words have different Size(Calibri 8,calibri 11 and calibri 14).Can this be achieved.Sorry for botherig you again for help.

 

[RickXL]

Hi again,

I have made some changes.
The code now uses two columns: One for the shape name and another for the shape text.

Rectangle 1	A BC
Rectangle 2	Rect
Rectangle 3	Shape
Rectangle 4	End
Rectangle 5	New One

<tbody>
</tbody>

The macro counts the names in the name column (A) so it will save you from having to change it.
Each character in turn is examined to determine its font, size and color.

Sub xx()
    Dim i As Long, j As Long
    Dim NameColumn As String, TextColumn As String
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    NameColumn = "A"                ' Set to the shape name column
    TextColumn = "B"                ' Set to the text column
    Set ws1 = Worksheets("Sheet1")  ' Sheet name for shapes
    Set ws2 = Worksheets("Sheet2")  ' Sheet name for text
    
    For i = 1 To ws2.Cells(Rows.Count, NameColumn).End(xlUp).Row
        With ws1.Shapes(ws2.Range(NameColumn & i)).TextFrame
            .Characters.Text = ws2.Range(TextColumn & i).Value
            For j = 1 To Len(.Characters.Text)
                .Characters(j, 1).Font.Size = ws2.Range(TextColumn & i).Characters(j, 1).Font.Size
                .Characters(j, 1).Font.Name = ws2.Range(TextColumn & i).Characters(j, 1).Font.Name
                .Characters(j, 1).Font.Color = ws2.Range(TextColumn & i).Characters(j, 1).Font.Color
            Next
        End With
    Next

End Sub

 

[RickXL]

I am making up my own problems now!

This version also copies the cell's fill (interior) color to set the color of the shape.

Sub xx()
    Dim i As Long, j As Long
    Dim NameColumn As String, TextColumn As String
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    NameColumn = "A"                ' Set to the shape name column
    TextColumn = "B"                ' Set to the text column
    Set ws1 = Worksheets("Sheet1")  ' Sheet name for shapes
    Set ws2 = Worksheets("Sheet2")  ' Sheet name for text
    
    For i = 1 To ws2.Cells(Rows.Count, NameColumn).End(xlUp).Row
        With ws1.Shapes(ws2.Range(NameColumn & i))
            .TextFrame.Characters.Text = ws2.Range(TextColumn & i).Value
            .Fill.ForeColor.RGB = ws2.Range(TextColumn & i).Interior.Color
            For j = 1 To Len(.TextFrame.Characters.Text)
                .TextFrame.Characters(j, 1).Font.Size = ws2.Range(TextColumn & i).Characters(j, 1).Font.Size
                .TextFrame.Characters(j, 1).Font.Name = ws2.Range(TextColumn & i).Characters(j, 1).Font.Name
                .TextFrame.Characters(j, 1).Font.Color = ws2.Range(TextColumn & i).Characters(j, 1).Font.Color
            Next
        End With
    Next

End Sub

 

[John Ashok]

Great...this is what I Exactly wanted and perfectly meets my requirement.Thanks lot again for your help.
One more small issue I am facing though.I have noticed that many of my shape names are not in series like Rectangle 1,rectangle 2,rectangle 3 etc.
Is it possible to create a macro only for Renaming each shape name irrespective of their current name to a new name in series starting with first shape till last shape.This will solve my problem as currently code gives error due to this issue.Thanks again.

 

[RickXL]

It sounds as if you want something like this:

Sub yy()

    Dim i As Long
    Dim ws1 As Worksheet
    Dim Shape As Shape
    Dim Shapes As Shapes
    Dim Prefix As String

    Set ws1 = Worksheets("Sheet1")  ' Sheet name for shapes
    Prefix = "A"                    ' Prefix for Shape Names
    
    i = 1
    For Each Shape In ws1.Shapes
        Shape.Name = Prefix & i
        i = i + 1
        Debug.Print Shape.Name
    Next

End Sub

However, you will still have problems because it will number them in the order it wants to and not necessarily in the order you want. You will probably just have to make a stack of manual changes at some point.

 

[John Ashok]

Hi,
I tried this code but problem is not solved as already told by you.
As all my shapes are one below the other vertically Is it possible to simply assign the name of cell A1 to First shape,A2 to second Shape,A3 to third shape and so on.Thanks for the reply.

 

[RickXL]

If your shapes are in the correct order down the page then their Top (vertical position) property will increase as they go down the page.

So, if we list the shapes and Tops.
Sort by Top
Then rename in Top order we should be there.

Note renaming to and from the same prefix will probably cause problems.
To convert from an old A1, A2 sequence, say, you may need to run this twice. Once to rename A1m A2 to B1, B2 etc then again from Bs to As.

The code is a bit "cheap and cheerful". I just pasted relevant bits together. A temporary worksheet is created and deleted for the sort.

Sub zz()

    Dim i As Long
    Dim ws1 As Worksheet
    Dim Shape As Shape
    Dim Shapes As Shapes
    Dim Prefix As String
    Dim wsTemp As Worksheet

    Set wsTemp = Sheets.Add
    
    Set ws1 = Worksheets("Sheet1")  ' Sheet name for shapes
    Prefix = "A"                    ' Prefix for Shape Names
    
    i = 1
    For Each Shape In ws1.Shapes
        wsTemp.Range("A" & i).Value = Shape.Top
        wsTemp.Range("B" & i) = Shape.Name
        i = i + 1
    Next
    
    With wsTemp
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range("A:B")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    End With
    
    For i = 1 To ws1.Shapes.Count
        Set Shape = ws1.Shapes(wsTemp.Range("B" & i))
        Shape.Name = Prefix & i
        Debug.Print Shape.Name & " " & Shape.Top
    Next
    
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
End Sub

 

[John Ashok]

Genius....Thanks a lot.My problem is solved.Thank you very much for your help.

I also have another task in this file which I make manually every time.Can this be automated through a code.below is the requirement.

I have text in say sheet3 in cell range A1 to A50(Unique Text in each cell).I want macro to search for each of these(eg: A1 to A 50) text in Sheet1 Cells (which contains 100's of such unique text cells and no duplicate text).Each row of Sheet2 contains only one Text cell and it is present precisely in column K(no other columns have cells containing text) . when found it should insert 10 blank Rows just above the row in which row this text is present.(for eg if text is found in row no 182,it should insert 10 blank rows in row no 181.Then it should select all the objects in sheet4 and paste it in column "L", exactly 13 rows above the row in which these texts are found(text from sheet1 A1 to A50).eg if text is found in 182 row then it should paste object in column L row 169.
Can you pl help me with the code.