PDA

View Full Version : Macro to show shape based on adjacent cell outcome



hunsnowboard
02-08-2009, 11:55 AM
Hi Everyone! I have this annoying problem with shapes. Please see the attached file.

My problem is the following:
On Sheet1 I have two important cells (C3 and D3). C3 is green and D3 is blue. C3 shows an outcome of a difficult counting which is not relevant to this problem. So C3 shows a percentage outcome. And based on the outcome of C3 I would like D3 to show a shape. These shapes are pie chart shapes. On the worksheet JPG you can see these shapes which are named: A, B, C, D, E and F. (i did not add all the shapes). As you can see each shape stands for an amount range (for example shape B stands for 0,001 and 0,05). So if on Sheet1 the outcome of C3 is between 0,001 and 0,5, range D3 should show shape B. Of course as this macro is run many times, each time the outcome is different, the macro should show the relevant shape. Now, I really do not know how to begin, how to write the code, as I am new, and besides I have never worked with shapes. Any ideas, thoughts? Please help if you can! Thank you in advance!

hunsnowboard
02-08-2009, 12:16 PM
Edited for attachment!

Bob Phillips
02-08-2009, 02:07 PM
Sub CopyShape()
Dim shp As Shape
Dim OKToDelete As Boolean
Dim ShapeName As String
Dim sTest As String

For Each shp In Worksheets("Sheet1").Shapes

OKToDelete = True
sTest = ""
On Error Resume Next
sTest = shp.TopLeftCell.Address
On Error GoTo 0

If shp.Type = msoFormControl Then

If shp.FormControlType = xlDropDown Then

If sTest = "" Then

'keep it
OKToDelete = False
End If
End If
End If

If OKToDelete Then shp.Delete
Next shp

With Worksheets("Sheet1")

With .Range("C3")

Select Case True

Case .Value = 0: ShapeName = "A"

Case .Value > 0.001 And .Value <= 0.05: ShapeName = "B"

Case .Value > 0.05 And .Value <= 0.1: ShapeName = "C"

Case .Value > 0.1 And .Value <= 0.15: ShapeName = "D"

Case .Value > 0.15 And .Value <= 0.2: ShapeName = "E"

Case .Value > 0.2 And .Value <= 0.35: ShapeName = "F"
End Select
End With

Worksheets("Jpg").Shapes(ShapeName).Copy
.Paste
With .Range("D3")

Selection.Top = .Top + .Height / 2 - Selection.Height / 2
Selection.Left = .Left + .Width / 2 - Selection.Width / 2
End With
End With
End Sub

hunsnowboard
02-08-2009, 03:10 PM
Hi Xld! Thank you again for your help! I will check this macro tomorrow and give you a feedback on it!