View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Ken Johnson Ken Johnson is offline
external usenet poster
 
Posts: 1,073
Default Compare shapes for obtaining a value

Hi Mihai,
I seem to have overcome that AutoFilter problem just using "On Error
Resume Next". The error occurs, as you stated, at the line with
Intersect, so I placed "On Error Resume Next" immediately before that
line and "On Error GoTo 0" immediately after it. However, the same
error then occurred at Shp.TopLeftCell.Value = M, so I did the same
with that line. This got rid of the error and the code executed
correctly. I then removed those four extra lines to see if "On Error
Resume Next" placed just before the loop would be enough and not bother
with "On Error GoTo 0" at all (apparently the effect of "On Error
Resume Next" is cancelled once your code has finished). That worked so
I have left it at that.
I must admit I don't understand, firstly why that error is caused by
the AutoFilter and, secondly why my code executes as expected just by
bypassing the error. I might post a question, hopefully one of the
experts can clear it up.
Thanks for explaining those squashed up shapes that I discovered on the
A1 sheet, that was a mystery.
Here's the new code with just the one extra line...

Public Sub ShapeCellValue()
Dim Shp As Shape
Dim rngShpVal As Range
Dim J As Byte
Dim M As Byte
'Change Range("C3:F11") to suit your needs
'Grouped shapes outside this range are ignored
Set rngShpVal = _
Me.Range("C3:F11")
rngShpVal.ClearContents
On Error Resume Next
For Each Shp In Me.Shapes
M = 1
If Not Intersect(Shp.TopLeftCell, rngShpVal) _
Is Nothing Then
If Shp.Type = msoGroup Then
For J = 1 To Shp.GroupItems.Count
If Shp.GroupItems(J).Fill.Visible = True Then
If Shp.GroupItems(J).Fill.ForeColor. _
SchemeColor = 8 Then Let M = M + 1
End If
Next J
End If
Shp.TopLeftCell.Value = M
End If
Next Shp
End Sub

I've been using the code in a Worksheet_SelectionChange event procedure
so that when one of the shapes in the rngShpVal range is moved to a
different cell in that same range the code is automatically run when
the user clicks on a cell to deselect the moved shape. The only time it
doesn't run is when the user selects the same cell that was active
before moving the shape. This is not really a problem since one would
expect the user to eventually select another cell and the code will
then be triggered.

Ken Johnson