Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 eroa 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 ------------------------------------------------------------------------ mihai's Profile: http://www.excelforum.com/member.php...fo&userid=2808 View this thread: http://www.excelforum.com/showthread...hreadid=517685 |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
Thanks again for the help Ken. Mihai -- mihai ------------------------------------------------------------------------ mihai's Profile: http://www.excelforum.com/member.php...fo&userid=2808 View this thread: http://www.excelforum.com/showthread...hreadid=517685 |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare shapes for obtaining a value
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
excel document with shapes on it but the shapes do not print | Excel Worksheet Functions | |||
Naming Auto Shapes and Creating new Shapes | Excel Discussion (Misc queries) | |||
When drawing shapes in excel the shapes keep disappearing | Excel Discussion (Misc queries) | |||
How can i get more 3D shapes for Auto shapes in excel? | Excel Discussion (Misc queries) | |||
How can i get more 3D shapes for Auto shapes in excel? | Excel Discussion (Misc queries) |