VBA Grid of Shapes

[samc2696]

Hi all

I have this macro that creates a column of circles, one for each cell in the range selected.

I don't know how to edit it to make it so that the result is no more than 5 columns wide and then x amount of rows depending on how many cells are selected.

Can someone help, please?

Sub Condit_Shapes()

Dim c, Rng As Range
Dim W, H, Gut As Integer
Dim Shp As String
Dim X, X_Start, Y As Integer
Dim rw, cl, rw_counter, cl_counter As Integer
Dim fnt, fnt_color As String
Dim fnt_size As Integer


'Set the range
Set Rng = Selection


'Count the columns and rows
rw_counter = Selection.Rows.Count
cl_counter = Selection.Columns.Count


'Set the width, height, shape type and gutter
W = 30
H = 30
Shp = msoShapeOval
Gut = 5


'Set the font characteristics
fnt = "BBC Reith Sans cd"
fnt_size = 8
fnt_color = 4210752


'Set the X,Y co-ordinates
X_Start = Selection.Cells(1, cl_counter).Offset(, 2).Left
X = X_Start
Y = Selection.Cells(1, 1).Top


'iterate through rows
For rw = 1 To rw_counter


    'iterate through columns
    For cl = 1 To cl_counter
        
        'If the cell has formatting, if not, create shape
        If Selection.Cells(rw, cl).Value <> "" Then
            With ActiveSheet.Shapes.AddShape(Shp, X, Y, W, H)
                .Name = Str(rw) + "," + Str(cl)
                .Fill.ForeColor.RGB = Selection.Cells(rw, cl).DisplayFormat.Interior.Color
                '.Fill.ForeColor.TintAndShade = -0.2
                '.Adjustments(1) = 0.05
                .Line.Visible = msoFalse
                With .TextFrame
                    .HorizontalAlignment = xlHAlignLeft
                    .VerticalAlignment = xlVAlignTop
                    
                End With
            End With
        
        Else:
            With ActiveSheet.Shapes.AddShape(Shp, X, Y, W, H)
                .Name = Str(rw) + "," + Str(cl)
                .Fill.ForeColor.RGB = 12566463
                '.Fill.ForeColor.TintAndShade = -0.2
                '.Adjustments(1) = 0.05
                .Line.Visible = msoFalse
            End With
        End If
        
        X = X + W + Gut
    
    Next cl
    
    X = X_Start
    Y = Y + H + Gut
    
Next rw




End Sub

Many thanks
Sam

 

[Yongle]

Insert this line

    Selection.Resize(Selection.Rows.Count, WorksheetFunction.Min(5, Selection.Columns.Count)).Select

above this line

    Set Rng = Selection

 

[samc2696]

Thanks for the quick reply.

There doesn't appear to do anything I still just get one column.

 

[Yongle]

Are you selecting as a single range or multiple ranges?

VBA is reselecting either 5 columns or your selection if fewer columns - you asked for a maximum of 5 columns

 

[samc2696]

Its a single range i.e. a column of cells

 

[Yongle]

How many columns are you selecting?
Works for me

 

[Yongle]

If you want 5 columns regardless then..

Selection.Resize(Selection.Rows.Count, 5).Select

(but you asked for "a maximum of 5 columns")

 

[Yongle]

I assume that the code is iterating through every selected cell

If it is not doing that then you need to work out why

 

[samc2696]

I don't think I have explained myself well enough.

It creates a 'column' of shapes, not about selecting 5 columns.

The user selects a column of data, and the output is x amount of shapes arranged as a column. However, I want the output to be more of a grid of shapes (5 columns wide) rather than a single column.

Thanks
Sam