Avatar of ExpExchHelp
ExpExchHelpFlag for United States of America asked on

Shape "Pie" -- use VBA to modify

Experts:

Using Google, I came across the code (see below) and would like to slighly modify it.   [See attached XLS for details.]

That is, the "pie" shape displays by default 75% of a circle/pie.   As you know, when using the yellow dots, I can increase/decrease the shape.  

I've looked through the shape properties but cannot seem to find the property that indicates the angle/size (not really sure what this 'yellow dot' property is called.

So, in pseudo code, I'd like to add a line of code into the function below which may read the following:
Selection.ShapeRange.Size = 25%.... this would allow me to always keep the smaller "pie" vs. the default size.

Does know how to modify the code below to accomplish this?   Again, please refere to XLS for visualization details.


If Range("e15").Value < 0.85 Then
    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

Open in new window

Pie.xls
Microsoft Excel

Avatar of undefined
Last Comment
ExpExchHelp

8/22/2022 - Mon
byundt

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
ASKER CERTIFIED SOLUTION
Rory Archibald

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
ASKER
ExpExchHelp

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
ASKER
ExpExchHelp

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
Your help has saved me hundreds of hours of internet surfing.
fblack61
Rory Archibald

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

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. ;)
byundt

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
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Rory Archibald

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

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
Rory Archibald

You can click the Request Attention link and ask for the question to be reopened.
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
ASKER
ExpExchHelp

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

Open in new window

ASKER
ExpExchHelp

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

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

Open in new window

Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
ExpExchHelp

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
Rory Archibald

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

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
I started with Experts Exchange in 2004 and it's been a mainstay of my professional computing life since. It helped me launch a career as a programmer / Oracle data analyst
William Peck
Rory Archibald

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

So not the same rules then!
ASKER
ExpExchHelp

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
Rory Archibald

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

Open in new window


adjust each section as necessary.
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
ExpExchHelp

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
Rory Archibald

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.
ASKER
ExpExchHelp

rorya, byundt:

Agreed... makes complete sense.   The new thread can be found at:
https://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28186274.html

Thanks for your continued assistance.

EEH
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck