Deleting duplicate shapes using VBA?

[levifunk]

I've got a few sheets with arrows on them. Through editing, copy/pasting... there are arrows on top of arrows on top of arrows. Sometimes 40+ arrows are in one spot. (It looks like there is 1, but 39 are hidden behind it.) Its really lagging the open time at this point.

I'm wondering how I could write a vba script to look and see if there are more than 1 shape in a spot and if there are, delete all but 1.

This is close to what I am looking for:
http://www.mrexcel.com/forum/showthread.php?t=81462

 

[BrandonWLH]

Loop through all shapes, compare shape.left, shape.top value, if equal, delete it unles its the 1st one encountered.

Put each shape that is 'valid' into an array, i.e., the 1st occurance of a top,left that is unique and then every other shape check it vs the top/left of the shapes in the array. If the top/left are in there, delete that shape, if the top/left isnt in there, add it to the array.

When done, the array will contain all the shapes with a unique position.

 

[levifunk]

So how would you edit the code from the other thread?

Sub Test()
Dim Sh As Shape
With Worksheets("Sheet1")
   For Each Sh In .Shapes
       If Not Application.Intersect(Sh.TopLeftCell, .Range("C1:C50")) Is Nothing Then
         If Sh.Type = msoPicture Then Sh.Delete
       End If
    Next Sh
End With
End Sub

 

[BrandonWLH]

Sub Test()
dim i as integer
i=1
 Dim Sh As Shape
 dim arr(1 to whatever) as shape
 With Worksheets("Sheet1")
   For Each Sh In .Shapes
       if not UniqueShape(sh, arr) then 
          sh.delete
       else
          arr(i) = Sh 
          i=i+1
       End If
   Next Sh
 End With
End Sub
 
function UniqueShape(sh as shape, arr() as shape )
 
   for x=1 to whatever
     if arr(x) = "" goto jumpout:
     if arr(x).left = sh.left AND arr(x).top = sh.top then
        UniqueShape=False
        exit function
     end if
   next x
 
jumpout:
  UniqueShape=True
end functions

Something like that.

 

[levifunk]

Is "arr()" suppose to be a shape? I'm not sure how you are trying to work this, what does arr represent?

I'd like to go from cell to cell and in each cell remove all shapes except 1.

Levi

 

[BrandonWLH]

We're going through the shapes on the sheet, not the shapes per cell.

arr() is an array of shapes.
any var with a () after it is an array.

The idea is that you check every shapes location against the locations of the shapes in the array arr().

It starts as an empty array.

You check the 1st shape, since the array is empty, that shape is unique, so it adds it to the array. They the code gets the 2nd shape on the sheet and now is checks the second shapes location vs the location of the shapes in the arr() array. If the new shapes location is not in the shape array, you add it to the arr() array of shapes as well and continue to check every shape against the shapes in an array.


Its no different than pulling coins and keeping unique coins. you Take the 1st penny out, you keep it and put it in a new bowl. You pull a nickle, you keep it, put it in the new bowl withthe penny, you pull a penny now, and since you have a penny slready in the new bowl, you throw that penny away. Wnen you are done you will have 1 of every coin type.

 

[levifunk]

ah, ok, i get how you're doing it now.

So, it errors on

If arr(x) = "" Then

"Object variable or With block variable not set"

Any ideas?

 

[BrandonWLH]

Come on man..

Should be arr(x)="" wouldn't work. arr(x) is a shape, its not going to ="", I was typing fast to answer assuming you could figure what I was trying to show you. Try arr(x) is Nothing, etc. You just need to check when you hit the end of the data in the array. You could also pass i into the function and compare i to x in the UniqueShape function. if x>i then gotro jumpout:

 

[levifunk]

It never gets to the UniqueShape=False. I believe its because arr(x) never gets assigned anything, so I added this:

     If arr(x) Is Nothing Then
        arr(x).Top = sh.Top
        arr(x).Left = sh.Left
        GoTo jumpout:
     End If

However, I get the same error about the variable not being set. I assume there is a syntax error?

 

[levifunk]

Got it to work with a slight modification:

Sub Delete_Dup_Shapes()
 Dim sh As Shape
 Dim arr(1 To 10000) As Shape
 Dim arr_t(1 To 10000) As Double
 Dim arr_l(1 To 10000) As Double
 
 'With Worksheets("MADC")
 With ActiveSheet
    For Each sh In .Shapes
        If Not UniqueShape(sh, arr_t, arr_l) Then
            sh.Delete
        End If
    Next sh
 End With
End Sub
 
Function UniqueShape(sh As Shape, arr_t() As Double, arr_l() As Double)

   For x = 1 To 10000
     If arr_t(x) = 0 Then
        arr_t(x) = sh.Top
        arr_l(x) = sh.Left
        GoTo jumpout:
     End If
     If arr_l(x) = sh.Left And arr_t(x) = sh.Top Then
        UniqueShape = False
        Exit Function
     End If
   Next x
 
jumpout:
  UniqueShape = True
End Function