VBA to List of Cells Inside Area of Freeform Shape

[platypus007]

Hi I have hard time solving this:

I have one Freeform Shape and I need to create VBA which will enlist all cells inside of this Freeform Shape.

What is the best way to do it?

Thank you very much

Victor

 

[Norie]

Victor

If you have reference to the freeform shape then you can get it's TopLeftCell and BottomLeftCell properties and use them to define the range that the shape is contained in.

For example.

Dim shp As Shape
Dim rng As Range

    With ActiveSheet
        Set shp = .Shapes("Freeform 1")
        Set rng = .Range(shp.TopLeftCell, shp.BottomRightCell)
    End With
    
    rng.Select

If you want something that only returns the cells that the shape itself covers then you could look at it's Vertices collection but I think that might get a bit complicated.

 

[platypus007]

Thanks for answer but my Freeform has irregular shape (under 200 nodes points ) and under this freeform shape is something around 100 cells

 

[Norie]

In the code I posted rng is a reference to every cell that's in the range the freeform shape is contained within.

If you wanted to list every cell in that range you could use a loop.

For Each cl in rng.Cells
    Debug.Print cl.Address(0,0)
Next cl

If that's not what you want to do then you'll need to explain further.

 

[platypus007]

I need result like this - in form of list for each of my Freeform shape (which cells are under Shape)

Or to check in each of cell if the Specific Freeform Area is above this cell:

Thanks

 

[Yongle]

As @Norie stated, it will be complicated to identify every cell which is lying inside the freeform shape outline
But here is something to get you started if that is what you need to do
Please post your final code here if you manage to solve the puzzle

To test
- create a NEW workbook
- insert the code in a module
- insert a freeform shape in Sheet1
- run the code
- a sheet is added by VBA listing the x and y co-ordinates of each point
- the unit values match those returned by Range("A1").Left, Range("A1").Top etc

Sub ShapeNode_CoOrds()
    Dim i As Long, shp As Shape, shpNode As ShapeNode, x As Double, y As Double, ws As Worksheet
    With ActiveSheet
        Set shp = .Shapes(1)
        Set ws = Sheets.Add
        ws.Columns("A:C").ColumnWidth = 15
        For i = 1 To shp.Nodes.Count
            Set shpNode = shp.Nodes.Item(i)
            x = shpNode.Points(1, 1)
            y = shpNode.Points(1, 2)
            ws.Cells(i, 1).Resize(, 3) = Array(i, x, y)
        Next i
    End With
End Sub

Question
- why are you using a freeform shape for this when you could simply click on outline cells and then infill
- consider using ... Selection_Change, BeforeDoubleClick, BeforeRightClick events

 

[platypus007]

I found this code by you Norie in another post - which will get XY positions:

VBA Shape Node Points x position

Sub GetPoints()
Dim sh
Dim nd
Dim xy
Dim nodemsg As String
Dim I
    Set sh = ActiveSheet.Shapes("Freeform 3")

    For Each nd In sh.Nodes
        xy = nd.Points
        I = I + 1
        nodemsg = nodemsg & "Node " & I & ": x =" & xy(1, 1) & " y=" & xy(1, 2) & vbCrLf
    Next
    MsgBox nodemsg
End Sub

 

[platypus007]

As @Norie stated, it will be complicated to identify every cell which is lying inside the freeform shape outline
But here is something to get you started if that is what you need to do
Please post your final code here if you manage to solve the puzzle

To test
- create a NEW workbook
- insert the code in a module
- insert a freeform shape in Sheet1
- run the code
- a sheet is added by VBA listing the x and y co-ordinates of each point
- the unit values match those returned by Range("A1").Left, Range("A1").Top etc

Sub ShapeNode_CoOrds()
    Dim i As Long, shp As Shape, shpNode As ShapeNode, x As Double, y As Double, ws As Worksheet
    With ActiveSheet
        Set shp = .Shapes(1)
        Set ws = Sheets.Add
        ws.Columns("A:C").ColumnWidth = 15
        For i = 1 To shp.Nodes.Count
            Set shpNode = shp.Nodes.Item(i)
            x = shpNode.Points(1, 1)
            y = shpNode.Points(1, 2)
            ws.Cells(i, 1).Resize(, 3) = Array(i, x, y)
        Next i
    End With
End Sub

Question
- why are you using a freeform shape for this when you could simply click on outline cells and then infill
- consider using ... Selection_Change, BeforeDoubleClick, BeforeRightClick events

I need this because user need to draw Freeformshape as Area in which he Include/Exclude fixed points (circle shapes) above Map Picture located in this sheet.
Simplify:
1st layer (picture - as map)
2nd layer (freeform circles - static points)
3rd layer (freeform area - which include/exclude 2nd layer)

by drawing 3rd layer user determine which points are in/out

complicated solution - at this time not usable for me - is in this topic - it is usable only for something around 200 points and for each point (cell) is need to run API code and on i9 processor is this limit
VBA to check if circles are inside of freeform area or not

 

[Yongle]

good luck with that
hopefully someone with more knowledge comes along to help - perhaps @Jaafar Tribak (who helped with thread linked in post#8)

 

[Jaafar Tribak]

Hi I have hard time solving this:

I have one Freeform Shape and I need to create VBA which will enlist all cells inside of this Freeform Shape.

What is the best way to do it?

Thank you very much

Victor

Are you looking to have the results in formulaes or from a Macro ?