File size growing growing exponentially

[Steve]

I have a file that has been growing and now is over 8 MB. I checked lots of
things from similar discussions and when I ran this from Ron de Bruin it went
from 8.31MB to 822 KB >

Sub Shapes1()
'Delete all Objects except Comments
On Error Resume Next
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0
End Sub

So on the original worksheet tabs I tried this from another discussion >

?activesheet.shapes.count
10439
?activesheet.shapes.count
20567

No wonder! I should have zero on the first one and 20 (buttons which have
"send report" on the face and are tied to macros) on the second one.

How can I adapt the "Shapes Deleting" macro to not eliminate the ones I want
when try to get rid of the other 20547 on the one sheet?

 

[Jacob Skaria]

Dear Steve

Mention the 20 shape names as a comma separated string...like below and run
the below macro.... Make sure the names are exactly same as the shape
names....For example the by default name for Rectangle come as 'Rectangle 1'
and not 'Rectangle1'...Try and feedback


Sub Macro()
Dim lngTemp As Variant
Dim strShapes As String

strShapes = "Rectagle 10,Rectangle 2,Rectangle 31"
strShapes = strShapes & ",Rectagle 32,Rectangle 35,Rectangle 70"


For lngTemp = 1 To ActiveSheet.Shapes.Count
If InStr(1, "," & strShapes & ",", "," & ActiveSheet. _
Shapes(lngTemp).Name & ",", vbTextCompare) = 0 Then
ActiveSheet.Shapes(lngTemp).Delete
End If
Next
End Sub

 

[Don Guillett]

The first one should make a list for you on a clean worksheet. Then, put an
x in col c of that sheet and run the second.

Sub makelistofshapes()
r = 2
For Each sh In Sheets("yoursheetnamehere").Shapes
Cells(r, 1) = sh.Name
Cells(r, 2) = sh.TopLeftCell.Address
r = r + 1
Next sh
End Sub

Sub deleteselectedshapes()
On Error Resume Next
For Each c In Range("a2:a22")
If UCase(c.Offset(, 2)) = "X" Then
Sheets("yoursheetnamehere").Shapes(c).Cut
End If
Next
End Sub

 

[Jacob Skaria]

Another way is to select the cell range of shapes which are to be kept...The
below macro will remove all other shapes from the Active worksheet.

Sub RemoveShapes()
Dim rngMyRange As Range
Dim shpMyShape As Shape
Set rngMyRange = Selection
For Each shpMyShape In ActiveSheet.Shapes
If Application.Intersect(rngMyRange, shpMyShape.TopLeftCell) _
Is Nothing Then shpMyShape.Delete
Next shpMyShape
End Sub

 

[Gini]

While the previous solutions are great for programmer-types, there is a simpler (and probably faster) solution: Simply save the file to another version of Project, (File - Save As - in the "Save as Type" box near the bottom of the dialog select an earlier version of Project, such as "Microsoft Project 2000-2003). The next time you save or autosave, Project will tell you that your file isn't the current version and offer to update.

After you close and re-open the file, the size will show as much smaller. This eliminates the problem of losing comments or other pieces and parts that the macros above will take out.