Thread: Shape Name and Location Report - an example

No question here, just an example procedure for the archive.

Create a worksheet report for all Shapes found on the active worksheet.
The report shows the Shape names and top left corner cell locations for
the active worksheet

Sub ShapesReportForActiveSheet()

' Creates a worksheet report for all shape names and locations
'for the active worksheet

Dim ShapeCells As Range
Dim TargetSheet, ShapeSheet As Worksheet
Dim Row As Integer
Set TargetSheet = ActiveSheet

On Error Resume Next
''Check for presence of any shapes on active worksheet
If ActiveSheet.Shapes.Count = 0 Then
MsgBox "There are no Shapes present on this worksheet"
Exit Sub
End If

' If Shapes present, then identify location(s) of top left corner
of each Shape.
' and proceed with report

For Each sh In ActiveSheet.Shapes

If ShapeCells Is Nothing Then
Set ShapeCells = sh.TopLeftCell
Else
Set ShapeCells = Union(sh.TopLeftCell, ShapeCells)
End If

Next

'Add the report worksheet

Application.ScreenUpdating = False

Set ShapeSheet = ActiveWorkbook.Worksheets.Add
ShapeSheet.Name = "Location of Shapes in " & ShapeCells.Parent.Name

'Set up the column headings
With ShapeSheet

Range("A1") = "Shape Name"
Range("B1") = "Top Left Cell Address"
Range("A1:B1").Font.Bold = True

End With

TargetSheet.Activate

'Process each shape

Row = 2

For Each sh In ActiveSheet.Shapes

Application.StatusBar = Format((Row - 1) / ShapeCells.Count,
"0%")

ShapeSheet.Cells(Row, 1) = sh.Name
ShapeSheet.Cells(Row, 2) = sh.TopLeftCell.Address

Row = Row + 1

Next

'Adjust column widths
ShapeSheet.Columns("A:B").AutoFit
Application.StatusBar = False

ShapeSheet.Activate

Range("A2").Select

End Sub

Search criteria:
Shapes report return shape locations return shape names get shape names

Your routine works fine. A few comments, some trivial:

> Dim TargetSheet, ShapeSheet As Worksheet

TargetSheet is declared as variant

> Dim Row As Integer

When working with rows normally better to declare as Long, though in this
case not a problem as unlikely to exceed 32k

> Set ShapeCells = Union(sh.TopLeftCell, ShapeCells)

This loop is redundent, ShapeCells is only used as in the status bar for
it's .Count property.

Dim nShpCnt as Long

On error resume next
nShpCount = ActiveSheet.Shapes.Count

With a large number of shapes with topleftcell's in non-contiguous cells a
loop and union like that would get exponentionally slower and for no useful
purpose. I work with many '000 shapes !

> Set ShapeSheet = ActiveWorkbook.Worksheets.Add
> ShapeSheet.Name = "Location of Shapes in " & ShapeCells.Parent.Name

When naming a sheet best to test if the named sheet already exists. If user
repeats the macro on same sheet it will. If it does maybe insert a couple of
columns so user can retain history of previous records.

> For Each sh In ActiveSheet.Shapes

Why not
For Each sh In TargetSheet.Shapes

Then no need to activate sheets

Could write details to a Redim'ed array then dump in one go onto the sheet.
Much faster and no need to bother with updating progress in the StatusBar
and no need disable screen updating.

Regards,
Peter T


<aztecbrainsurgeon@yahoo.com> wrote in message
news:1143848173.421587.321970@u72g2000cwu.googlegroups.com...
> No question here, just an example procedure for the archive.
>
> Create a worksheet report for all Shapes found on the active worksheet.
> The report shows the Shape names and top left corner cell locations for
> the active worksheet
>
> Sub ShapesReportForActiveSheet()
>
> ' Creates a worksheet report for all shape names and locations
> 'for the active worksheet
>
> Dim ShapeCells As Range
> Dim TargetSheet, ShapeSheet As Worksheet
> Dim Row As Integer
> Set TargetSheet = ActiveSheet
>
> On Error Resume Next
> ''Check for presence of any shapes on active worksheet
> If ActiveSheet.Shapes.Count = 0 Then
> MsgBox "There are no Shapes present on this worksheet"
> Exit Sub
> End If
>
> ' If Shapes present, then identify location(s) of top left corner
> of each Shape.
> ' and proceed with report
>
> For Each sh In ActiveSheet.Shapes
>
> If ShapeCells Is Nothing Then
> Set ShapeCells = sh.TopLeftCell
> Else
> Set ShapeCells = Union(sh.TopLeftCell, ShapeCells)
> End If
>
> Next
>
> 'Add the report worksheet
>
> Application.ScreenUpdating = False
>
> Set ShapeSheet = ActiveWorkbook.Worksheets.Add
> ShapeSheet.Name = "Location of Shapes in " & ShapeCells.Parent.Name
>
> 'Set up the column headings
> With ShapeSheet
>
> Range("A1") = "Shape Name"
> Range("B1") = "Top Left Cell Address"
> Range("A1:B1").Font.Bold = True
>
> End With
>
> TargetSheet.Activate
>
> 'Process each shape
>
> Row = 2
>
> For Each sh In ActiveSheet.Shapes
>
> Application.StatusBar = Format((Row - 1) / ShapeCells.Count,
> "0%")
>
> ShapeSheet.Cells(Row, 1) = sh.Name
> ShapeSheet.Cells(Row, 2) = sh.TopLeftCell.Address
>
> Row = Row + 1
>
> Next
>
> 'Adjust column widths
> ShapeSheet.Columns("A:B").AutoFit
> Application.StatusBar = False
>
> ShapeSheet.Activate
>
> Range("A2").Select
>
> End Sub
>
> Search criteria:
> Shapes report return shape locations return shape names get shape names
>

This is brilliant and almost exactly what I need. What would the code be to report on shapes within a given range L2:Z5?

Would it also be possible to log the shapes Alternative Text in the same cells on Sheet2 for example, ideally using the alternative text?