Compare shapes for obtaining a value

[mihai]

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 |
+-------------------------------------------------------------------+

 

[Ken Johnson]

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

 

[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

 

[mihai]

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

 

[Ken Johnson]

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

 

[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

 

[Ken Johnson]

Hi Mihai,
I've found out the cause of the error.
Excel includes in the Sheet's Shapes collection the Drop Down arrow
belonging to the AutoFilter and this does not have a TopLeftCell
property, so it looks like a safer solution would be to detect such a
shape so that the loop can then skip to the next shape.
So, what you could do is delete the line with "On Error Resume Next",
add the following line so that it is the next line immediately after
the "For Each Shp in etc" line..

If Left(Shp.Name,9) <> "Drop Down" Then

Then add another "End If" line so that it is the line immediately
before the "Next Shp" line.

Hope that all makes sense.

Ken Johnson

 

[mihai]

Hi Ken,

I sade earlier that I wrote a code that dose the opposite. Evaluate a
cells value and pastes the proper shape. I will put it her. Maybe
somebody needs it. It's not the best one, the most efficient one but it
doses the job. I translated most of my comments. I call this code
throught a command button from a form.

Private Sub cmdfill_Click()

On Error GoTo eroare
GoTo start
eroare:
oldstatusbar = Application.DisplayStatusBar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
MsgBox "Error number" & Err & ":" & Error(Err) & vbCrLf & "Se cere
interventia lui Mihai."
Unload frmintimpinare
Workbooks("tm macro.xls").Close False
End

start:
Dim lastrow As Long
Dim emptycol, lastrow, e As String
Dim mydocument As Worksheet
Dim shp As Shape
Dim c, s As Variant
'hide frmintimpinare
Unload frmwelcome
'Request patienes in statusbar
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Patiens!! Se lucreaza cu cifre. Imediat
termin. "
'Reveal all tabels
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
'last row
Range("B7:B100").Select
Selection.Find(what:="", after:=ActiveCell, LookIn:=xlFormulas,
lookat:=xlPart, _
searchorder:=xlByRows, searchdirection:=xlNext,
MatchCase:=False).Activate
lastrow = ActiveCell.row - 1
'Find cell "Activity/Activitate" and address
For Each a In Range("B4:EY4")
If a.Value = "Activity/Activitate" Then
adresaAA = a.Address
'Activate cell "Activity/Activitate"
Range(adresaAA).Activate
'Selecte till EY4 !! watch out for new projects!
Range(adresaAA & ":$EY$4").Select
Selection.Find(what:="", after:=ActiveCell, _
LookIn:=xlFormulas, lookat:=xlPart,
searchorder:=xlByColumns, searchdirection:=xlNext, _
MatchCase:=False).Activate
'find the letter of the empty column after "Activity/Activitate"
emptycol = "$" & Split(ActiveCell.Offset(0, -1).Address,
"$")(1)
lastrow = "$" & lastrow
'Define selection
e = Range(adresaAA).Offset(3, 1).Address & ":" & (emptycol &
lastrow)
Set myrange = ActiveSheet.Range(e)
'Count the grades
one = Application.WorksheetFunction.CountIf(myrange, 1)
two = Application.WorksheetFunction.CountIf(myrange, 2)
three = Application.WorksheetFunction.CountIf(myrange, 3)
four = Application.WorksheetFunction.CountIf(myrange, 4)
'Write grades
ActiveCell.Offset(lastrow - 3, -1).FormulaR1C1 = "1=" & one
ActiveCell.Offset(lastrow - 2, -1).FormulaR1C1 = "2=" & two
ActiveCell.Offset(lastrow - 1, -1).FormulaR1C1 = "3=" & three
ActiveCell.Offset(lastrow, -1).FormulaR1C1 = "4=" & four
End If
Next
'Back to A1
Range("A1").Select
'check if the shapes in the legend have proper names "Group 1, 2, 3,
4"
'clean cell to be used
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A1").Activate
'write the names of all the shapes in EZ7:EZ8000
Set mydocument = ActiveSheet
Range("EZ7").Activate
For Each shp In mydocument.Shapes
c = Left(shp.Name, 8)
ActiveCell.FormulaR1C1 = c
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Next
'look for the correct names or end
With ActiveSheet.Range("EZ7:EZ8000")
Set s = .Find("Group 1", ActiveCell, xlFormulas, xlWhole, xlByRows,
xlNext, False)
If s Is Nothing Then
Range("A1").Activate
MsgBox "From the legend is missing the shape with the name" & vbCrLf &
" Group 1" & vbCrLf & _
"Rename the first shape from legend to: Group 1", vbOKOnly, "ERROR
Name"
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A1").Activate
oldstatusbar = Application.DisplayStatusBar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
Workbooks("tm macro.xls").Close False
End
Else
Set s = .Find("Group 2", ActiveCell, xlFormulas, xlWhole, xlByRows,
xlNext, False)
If s Is Nothing Then
Range("A1").Activate
MsgBox "From the legend is missing the shape with the name" &
vbCrLf & " Group 2" & vbCrLf & _
"Rename the first shape from legend to: Group 2", vbOKOnly, "ERROR
Name"
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A1").Activate
oldstatusbar = Application.DisplayStatusBar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
Workbooks("tm macro.xls").Close False
End
Else
Set s = .Find("Group 3", ActiveCell, xlFormulas, xlWhole,
xlByRows, xlNext, False)
If s Is Nothing Then
Range("A1").Activate
MsgBox "Din Legenda lipseste desenul cu numele" & vbCrLf & "
Group 3" & vbCrLf & _
"Redenumiti al treilea desen din Legenda: Group 3", vbOKOnly,
"EROARE Nume"
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A1").Activate
oldstatusbar = Application.DisplayStatusBar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
Workbooks("tm macro.xls").Close False
End
Else
Set s = .Find("Group 4", ActiveCell, xlFormulas, xlWhole,
xlByRows, xlNext, False)
If s Is Nothing Then
Range("A1").Activate
MsgBox "Din Legenda lipseste desenul cu numele" & vbCrLf &
" Group 4" & vbCrLf & _
"Redenumiti al patrulea desen din Legenda: Group 4",
vbOKOnly, "EROARE Nume"
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A1").Activate
oldstatusbar = Application.DisplayStatusBar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
Workbooks("tm macro.xls").Close False
End
End If
End If
End If
End If
End With
'clean
Range("EZ7:EZ8000").Select
Selection.ClearContents
Range("A7").Activate
'for each cell find the address C7:EY200
For Each c In Range("C7:EY200")
e = c.Address
'test the value in the cell and past the proper shape and empty the
cell
If c.Value = 1 Then
Range(e).Activate
ActiveSheet.Shapes("group 1").Copy
ActiveCell.PasteSpecial
ActiveCell.ClearContents
Else
If c.Value = 2 Then
Range(e).Activate
ActiveSheet.Shapes("group 2").Copy
ActiveCell.PasteSpecial
ActiveCell.ClearContents
Else
If c.Value = 3 Then
Range(e).Activate
ActiveSheet.Shapes("group 3").Copy
ActiveCell.PasteSpecial
ActiveCell.ClearContents
Else
If c.Value = 4 Then
Range(e).Activate
ActiveSheet.Shapes("group 4").Copy
ActiveCell.PasteSpecial
ActiveCell.ClearContents
End If
End If
End If
End If
Next
'establish the properties for moving and redimensioning of the shapes
mydocument.Shapes.SelectAll
'Set sr = Selection.ShapeRange
With Selection
..Placement = xlMoveAndSize
..PrintObject = True
End With
Range("A7").Activate
'finish
'Old statusbar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
'Unload frmwelcome
MsgBox "Finish." & vbCr & vbLf & "Don't forget to save!", vbOKOnly,
"Info"
Workbooks("tm macro.xls").Close False
End
End Sub

 

[mihai]

Thanks again for the help Ken.

Mihai

 

[Ken Johnson]

Hi Mahai,
Thanks for that.
Also, you're welcome. Working on your problem has taught me a few new
things. The AutoFilter error was quite interesting.
Ken Johnson