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


wrote in message
oups.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