Shape Name and Location Report - an example
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
|