CODEWITHSUNDEEP
excelvba
Dan
Dan

Reputation: 95

Check if excel range has shape with VBA

Hi I'm trying to work through a table downloaded from a 3rd party that uses ticks (shapes) rather than text in the cells. The shapes have no textframe characters. I can't filter the ticks in excel so I want to replace then with text e.g. Yes. Here is my working code but get run time error 438 due to object errors I have tried the excel vba object model but can't get it to work. The VBE doesn't seem to have the Selection.ShapeRange

https://learn.microsoft.com/en-us/office/vba/api/excel.shape

https://learn.microsoft.com/en-us/office/vba/api/excel.shaperange

Here is my code

Sub ReplaceShapeswithYes()

' Inserts text where a shape exists

Dim ws As Worksheet
Dim NumRow As Integer
Dim iRow As Integer
Dim NumShapes As Long

Set ws = ActiveSheet

NumRow = ws.UsedRange.Rows.Count

For iRow = 2 To NumRow
    
    Cells(iRow, 10).Select
    'NumShapes = ActiveWindow.Selection.ShapeRange.Count ' tried both
    NumShapes = Windows(1).Selection.ShapeRange.Count
    
    If NumShapes > 0 Then
    Cells(iRow, 10).Value = "Yes"
    End If
            
Next iRow

End Sub

Many thanks

Upvotes: 0

Views: 1913

Answers (2)

Dan
Dan

Reputation: 95

This has done the trick

Sub ReplaceShapes()

'Replace all ticks with text

Dim NoShapes As Long
Dim iShape As Long
Dim ws As Worksheet
Dim r As Range
Dim Shp As Shape

Set ws = ActiveSheet

NoShapes = ws.Shapes.Count

For iShape = NoShapes To 1 Step -1:

Set Shp = ws.Shapes(iShape)

Set r = Shp.TopLeftCell

r.Value = "Yes"


Next iShape

End Sub

Upvotes: 1

FunThomas
FunThomas

Reputation: 29146

To get all shapes of a sheet, simply loop over the Shapes-collection of the sheet.

The text of a shape can be read with TextFrame.Characters.Text, but to be on the save side, you will need to check if a shape has really text (there are shapes that don't have any), see https://stackoverflow.com/a/16174772/7599798

To get the position withing a sheet, use the TopLeftCell-property.

The following code will copy the text of all shapes into the sheet and delete the shapes:

Sub shapeToText(Optional ws As Worksheet = Nothing)
    If ws Is Nothing Then Set ws = ActiveSheet
    
    Dim sh As Shape
    For Each sh In ws.UsedRange.Shapes
        If Not sh.TextFrame Is Nothing Then
            If sh.TextFrame2.HasText Then
                Dim s As String
                s = sh.TextFrame.Characters.Text
                sh.TopLeftCell = s
                sh.Delete
            End If
        End If
    Next
End Sub

Upvotes: 1

Related Questions