Create Shapes based on values

[Snaybot]

Hi all

If I have the values in column A

A
B
C
D
A
F
C
E
E

I would like to create a shape 6 rectangular shapes with the text inside the shapes being A, B, C, D, E, F

Any Idea how I would do that in vba / a macro?

 

[JLGWhiz]

This will get you started.

Sub t()
Sheet1.Shapes.AddShape 1, 100, 100, 100, 50
    With Sheet1.Shapes(1)
        .Line.Style = xlSolid
        .TextFrame2.TextRange.Text = Sheet1.Range("A1").Value
    End With
End Sub

 

[JLGWhiz]

Try this for all six.

Sub tt()
Dim i As Long, x As Long
x = 100
    For i = 1 To 6
        Sheet1.Shapes.AddShape 1, x, 100, 100, 50
            With Sheet1.Shapes(i)
                .Line.Style = xlSolid
                .TextFrame2.TextRange.Text = Sheet1.Range("A" & i).Value
            End With
        x = x + 150
    Next
End Sub

 

[Domenic]

It looks like you want to create shapes based on the unique values in Column A. Accordingly, try...

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] CreateRectangles()

    [COLOR=darkblue]Dim[/COLOR] oDic [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] vItem [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] rCell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] Left [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] Top [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] Width [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] Height [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] LastRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    [COLOR=darkblue]Const[/COLOR] Gap [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR] = 10 [COLOR=green]'change the gap between rectangles accordingly[/COLOR]
    
    [COLOR=darkblue]If[/COLOR] TypeName(ActiveSheet) <> "Worksheet" [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    [COLOR=darkblue]If[/COLOR] LastRow < 2 [COLOR=darkblue]Then[/COLOR]
        MsgBox "No data is available.", vbInformation
        [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    Left = Range("B2").Left
    Top = Range("B2").Top
    Width = 200
    Height = 100
    
    [COLOR=darkblue]Set[/COLOR] oDic = CreateObject("Scripting.Dictionary")
    oDic.CompareMode = 1 [COLOR=green]'0 = case-sensitive; 1 = case-insensitive[/COLOR]
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] rCell [COLOR=darkblue]In[/COLOR] Range("A2:A" & LastRow)
        oDic.Item(rCell.Value) = ""
    [COLOR=darkblue]Next[/COLOR] rCell
    
    Worksheets.Add
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vItem [COLOR=darkblue]In[/COLOR] oDic.keys
        [COLOR=darkblue]With[/COLOR] ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=Left, Top:=Top, Width:=Width, Height:=Height)
            .TextFrame2.TextRange.Text = vItem
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        Top = Top + Height + Gap
    [COLOR=darkblue]Next[/COLOR] vItem
    
    [COLOR=darkblue]Set[/COLOR] oDic = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rCell = [COLOR=darkblue]Nothing[/COLOR]

[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Note that the macro assumes the following...

1) The sheet containing the data is the active sheet.

2) Column A contains the data, starting at Row 2.

3) The shapes are to be created in a newly created worksheet.

Make any necessary changes, as desired.

Hope this helps!