Shape "Pie" -- use VBA to modify

To make the pie shape display x% of a circle, try the following statement in your Worksheet_Change event sub:
        Selection.ShapeRange.Adjustments.Item(1) = 360 * (1 - Range("E15").Value) - 90

byundt:

Thanks for the response... this is getting there.

Need a slight adjustment though.    

For all values, e.g., between 0 and 0.85, I always want to display 25% of the shape.  
For all values, e.g., between 0.86 and 0.95, I always want to display 50% of the shape.
And, in another scenario, e.g., 0.96 to 1.00, I may want to display 50% of the shape AND flip it "horizontally.
And, in the final scenario, e.g., 0.96 to 1.00, I may want to display 50% of the shape AND flip it "vertically".

The above number/ranges are currently only estimates/dummy values.   Once the above is working though, making adjustments is straight-forward.

Essentially, I have will use these different shapes to mimic en "egg-shaped" oval to visualize an application.

Thanks in advance,
EEH

rorya:

I think your solution will give me exactly what I need... I've played with the two parameters and I can (eventually) design the exact areas of the shape.

There's only one piece missing... how can I modify the height of the pie (as I'm trying to replicate an egg-shaped region, I need to vertically strecth some elements of the total shape)?

Thanks,
EEH

You can modify the .Height property to whatever value you want (or use a multiple of the .Width for example)

Since Brad addressed, as far as I can see, your question as posed and did so before I did, I think he deserves some, or all, of the points. ;)

Rory,
Had you not taken the time to provide a better answer by rewriting the Worksheet_Change sub to use With blocks rather than Selection, you might have pipped me to the post. I don't begrudge the outcome.

Brad

Very kind, Brad but I still think a split would be fair. (I know it all evens out in the end generally, but still...)

rorya:

Without question, Brad is definitely one of the most experienced experts in this forum.   His solutions are always spot-on and illustrate his expertise.

In this case though (sorry), the provided answer did not exactly address what I was trying to solve... your was.  

I'll gladly reconsider but don't know how to reassign points once solutions have been accepted.

Cheers,
EEH

You can click the Request Attention link and ask for the question to be reopened.

rorya:

Will do...

In the meanwhile, I realized one conceptual error (which I've made).    Here's what I need to modify it.

- I have 4 different regions.
 
- For each region, I need to draw the "pie" differently (using your function with >> .Adjustments(2) << and >>  .Adjustments(1) = << property values.

- For each region I have a cell value ranges which determine a color code.   So, e.g., 0-20 will result in a red pie; 21-70 in a yellow pie; and 71 -100 in a green pie.

My questions:
- Right now, based on what I originally found on Google, the code below draws different shapes based on the value.   Again, instead of different shapes, I want the different angle/sizes of the pie shape.  

- And again, e.g., the values in each of the four cells (B1:B4), shall drive the color (red, yellow, green).    How can I integrate your function into the original code?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   ' ActiveSheet.Shapes(25).Select 'assuming one arrow is on the worksheet.

ActiveSheet.Shapes(1).Select
If Range("e15").Value < 0.85 Then

'ActiveSheet.Shapes.AddShape(msoShapeDownArrow, 619.5, 295.5, 30#, 33.75). _
        Select
    Selection.ShapeRange.AutoShapeType = msoShapePie
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End If
If Range("e15").Value > 0.85 And Range("e15").Value < 0.9 Then
   ' ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, 611.25, 249#, 45.75, _
        22.5).Select
    Selection.ShapeRange.AutoShapeType = msoShapeLeftRightArrow
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
 End If
 If Range("e15").Value > 0.9 Then
'ActiveSheet.Shapes.AddShape(msoShapeUpArrow, 609.75, 184.5, 27#, 30.75). _
        Select
    Selection.ShapeRange.AutoShapeType = msoShapeUpArrow
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 57
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
  End If
  ActiveCell.Select
End Sub

Select allOpen in new window

Attached is an illustration... sorry, forum didn't allow me to upload the XLS file (maybe too many drawings).
Illustration.JPG

It's not at all clear to me which values relate to which shapes, but here's the basic code - you simply need to tweak the ranges and values in the select case statement:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim shp As Shape
   Dim lColour As Long
   Dim lAdjustments(1 To 2) As Long
   Set shp = ActiveSheet.Shapes(1)

   Select Case Range("e15").Value
      Case Is < 0.85
         lColour = 10
         lAdjustments(1) = 90
         lAdjustments(2) = 180
      Case 0.85 To 0.9
         lColour = 13
         lAdjustments(1) = 270
         lAdjustments(2) = 0
      Case Is < 0.96
         lColour = 63
         lAdjustments(1) = 180
         lAdjustments(2) = 270
      Case Else
         lColour = 57
         lAdjustments(1) = 360
         lAdjustments(2) = 90
   End Select
   
   With shp
   
      With .Fill
         .Visible = msoTrue
         .Solid
         .ForeColor.SchemeColor = lColour
         .Transparency = 0#
      End With
      
      With .Line
         .Weight = 0.75
         .DashStyle = msoLineSolid
         .Style = msoLineSingle
         .Transparency = 0#
         .Visible = msoTrue
         .ForeColor.SchemeColor = lColour
         .BackColor.RGB = RGB(255, 255, 255)
      End With
      
      .Adjustments(1) = lAdjustments(1)
      .Adjustments(2) = lAdjustments(2)
   
   End With
End Sub

Select allOpen in new window

rorya:

Thanks so much... this is about the 90% solution.  

Here's the only piece that's missing...
- I'd like to display all four pie shapes at the same time.
- Each of the four shapes should be linked to a different data entry cell (right now, it's only "e15")... instead, I'd like to link Zone 1 to E15; Zone 2 to E16, ..., Zone 4 to E18.

How can this be accomplished as I should not copy the function "Worksheet_Change" four times and change it to "Worksheet_Change_1", "Worksheet_Change_2", etc., right?

Thank you in advance,
EEH

Do the exact same rules apply to each of the 4 shapes?

Yes.    

- Need to maintain ability to have different color codes for different value ranges in each shape.
- I will apply larger height for the top (two) shapes.  

That's all I can think of right now.

Thank you for your continued help on this.

EEH

Need to maintain ability to have different color codes for different value ranges in each shape.

So not the same rules then!

I was thinking in lines of structure.   But you're right, the following need to be maintained for each shape:

1. Different angles (Adjustment1, Adjustment2)
2. Different heights (top row vs. bottom row)
3. Linkage to four data entry cells (to drive different colors/status)

Does that help?

EEH

In that case I think you may as well just repeat the code for each cell and adjust the relevant variables - untested code:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rngCell As Range
   Dim shp As Shape
   Dim lColour As Long
   Dim lAdjustments(1 To 2) As Long
   
   If Not Intersect(Target, Range("E15:E18")) Is Nothing Then
   
      For Each rngCell In Intersect(Target, Range("E15:E18")).Cells
      
         Select Case rngCell.Address(0, 0)
            Case "E15"
               Set shp = ActiveSheet.Shapes(1)
            
               Select Case rngCell.Value
                  Case Is < 0.85
                     lColour = 10
                     lAdjustments(1) = 90
                     lAdjustments(2) = 180
                  Case 0.85 To 0.9
                     lColour = 13
                     lAdjustments(1) = 270
                     lAdjustments(2) = 0
                  Case Is < 0.96
                     lColour = 63
                     lAdjustments(1) = 180
                     lAdjustments(2) = 270
                  Case Else
                     lColour = 57
                     lAdjustments(1) = 360
                     lAdjustments(2) = 90
               End Select
            Case "E16"
               Set shp = ActiveSheet.Shapes(2)
            
               Select Case rngCell.Value
                  Case Is < 0.85
                     lColour = 10
                     lAdjustments(1) = 90
                     lAdjustments(2) = 180
                  Case 0.85 To 0.9
                     lColour = 13
                     lAdjustments(1) = 270
                     lAdjustments(2) = 0
                  Case Is < 0.96
                     lColour = 63
                     lAdjustments(1) = 180
                     lAdjustments(2) = 270
                  Case Else
                     lColour = 57
                     lAdjustments(1) = 360
                     lAdjustments(2) = 90
               End Select
            Case "E17"
               Set shp = ActiveSheet.Shapes(3)
            
               Select Case rngCell.Value
                  Case Is < 0.85
                     lColour = 10
                     lAdjustments(1) = 90
                     lAdjustments(2) = 180
                  Case 0.85 To 0.9
                     lColour = 13
                     lAdjustments(1) = 270
                     lAdjustments(2) = 0
                  Case Is < 0.96
                     lColour = 63
                     lAdjustments(1) = 180
                     lAdjustments(2) = 270
                  Case Else
                     lColour = 57
                     lAdjustments(1) = 360
                     lAdjustments(2) = 90
               End Select
            Case "E18"
               Set shp = ActiveSheet.Shapes(4)
            
               Select Case rngCell.Value
                  Case Is < 0.85
                     lColour = 10
                     lAdjustments(1) = 90
                     lAdjustments(2) = 180
                  Case 0.85 To 0.9
                     lColour = 13
                     lAdjustments(1) = 270
                     lAdjustments(2) = 0
                  Case Is < 0.96
                     lColour = 63
                     lAdjustments(1) = 180
                     lAdjustments(2) = 270
                  Case Else
                     lColour = 57
                     lAdjustments(1) = 360
                     lAdjustments(2) = 90
               End Select
         End Select
         
         FormatShape shp, lColour, lAdjustments
      Next rngCell
      
   End If
   
End Sub
Sub FormatShape(shp As Shape, lColour As Long, lAdj() As Long, Optional dblHeight As Double = 0)
   With shp
   
      With .Fill
         .Visible = msoTrue
         .Solid
         .ForeColor.SchemeColor = lColour
         .Transparency = 0#
      End With
      
      With .Line
         .Weight = 0.75
         .DashStyle = msoLineSolid
         .Style = msoLineSingle
         .Transparency = 0#
         .Visible = msoTrue
         .ForeColor.SchemeColor = lColour
         .BackColor.RGB = RGB(255, 255, 255)
      End With
      
      .Adjustments(1) = lAdj(1)
      .Adjustments(2) = lAdj(2)
      If dblHeight <> 0 Then .Height = dblHeight
   
   End With

End Sub

Select allOpen in new window

adjust each section as necessary.

rorya:

Again, thank you for your help.

I've copied the copy... I understand it's untested code.   At this time, I'm running into an error when changing values in E16:E18 (E15 works fine).

I've attached the current XLS with a notes section highlighting what's still missing.   [Btw, in order to upload the file, I had to change the extension from .xls to .txt.]

Again, I'm grateful for your help.

EEH
Pie4.xls

Your requirements appear to have completely changed from where we started so, as far as I'm concerned, this is a completely new question now and should be posted as such.

rorya, byundt:

Agreed... makes complete sense.   The new thread can be found at:
https://www.experts-exchange.com/questions/28186274/Use-VBA-to-modify-Pie-shape-color.html

Thanks for your continued assistance.

EEH