Hello,

I received a request to find a way to compare shapes from a table with
the shapes from the legend an so to obtain a value and write that in
the cell under the shape.
The shapes from the legend have predefine names like „Group 1”, „Group
2”. Her is a sample file. I’m not sure if this is possible.
In the past I did for this case the reverse one. I read the value from
the cell and pasted the appropriate shape from the legend over it
deleting the contents of the cell.
Dose anybody know a way to do this?

Thank you
Mihai


+-------------------------------------------------------------------+
|Filename: test1.zip |
|Download: http://www.excelforum.com/attachment.php?postid=4402 |
+-------------------------------------------------------------------+

--
mihai
------------------------------------------------------------------------
mihai's Profile: http://www.excelforum.com/member.php...fo&userid=2808
View this thread: http://www.excelforum.com/showthread...hreadid=517685

Hi mihai,
Your grouped shapes all consist of 3 GroupItems.
The grouped shape representing 1 has no GroupItems with
..Fill.ForeColor.SchemeColor = 8 (Black).
The grouped shape representing 2 has one GroupItems with
..Fill.ForeColor.SchemeColor = 8.
The grouped shape representing 3 has two GroupItems with
..FIll.ForeColor.SchemeColor = 8.
The grouped shape representing 4 has three GroupItems with
..FIll.ForeColor.SchemeColor = 8.

So, I suppose if you want the value in a cell to depend on the shape
that is in that cell, then it could be the result of counting the
number of GroupItems making up that shape that have a black fill plus
1.
Try this macro which I had working on your Test1 workbook

Public Sub ShapeCellValue()
Dim Shp As Shape
Dim rngShpVal As Range
Dim K As Byte
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 = _
ActiveSheet.Range("C3:F11")
rngShpVal.ClearContents
For Each Shp In ActiveSheet.Shapes
M = 1: K = 0
If Not Intersect(Shp.TopLeftCell, rngShpVal) _
Is Nothing Then
If Shp.Type = msoGroup Then
Let K = Shp.GroupItems.Count
For J = 1 To K
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

Ken Johnson

Hi mihai,
Just a little improvement, K is not really needed...

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 = _
ActiveSheet.Range("C3:F11")
rngShpVal.ClearContents
For Each Shp In ActiveSheet.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

Hi Ken,

Thank you very much. Your solutions worked perfect and it’s based on
such a simple idea. This is a typical situation of having an outside
perspective. Through the years helping others work with this file I
forgot that the shapes are not solid. I tested and used it on Friday on
the files made available by the sweet users. 45-55MB files! They deleted
rows or columns not noticing that Excel did not delete the shapes just
resized them so that they where not visible any more and the files kept
growing and they complained that there PC was slower. (After cleaning
you got a 7-16MB file)
I noticed that if AutoFilter is on, the list is not filtered just on,
the program fails at some point with the error „Runtime error 1004
Application-defined or object-defined error.” at the Intersect line.
Even if you deactivate AutoFilter you get the error you must reopen the
files.

Thank you

Mihai


--
mihai
------------------------------------------------------------------------
mihai's Profile: http://www.excelforum.com/member.php...fo&userid=2808
View this thread: http://www.excelforum.com/showthread...hreadid=517685

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

Sorry Mihai I have made a tiny mistake when pasting the code. I've used
the standard macro heading with the Worksheet_SelectionChange code.
I'll try again...
If you are using as a standard macro then use...

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 = _
ActiveSheet.Range("C3:F11")
rngShpVal.ClearContents
On Error Resume Next
For Each Shp In ActiveSheet.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

If you are using as Worksheet_SelectionChange event procedure in the A1
worksheet code module then use...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
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

Ken Johnson