VBA Help - Vertical organization display of items on a fixed chart

dfelz

New Member
Joined
Nov 18, 2015
Messages
4
Hello VBA Express team, I am new to this forum, and am looking for some help on a coding dilemma. First some background on the program, i did not write this entire program, it was given to me from a coworker who wanted it modified more to his needs and he knew i have some VBA experience (I am a mechanical engineer, not computer, so codding is not my specialty). I made a majority of the modifications that he wanted but am stuck on this one, that's where you guys and gals come in.

The program takes a list of projects and sorts them by the phase they are in (there are 7 available phases) then locates them horizontally within that phase section on the graph, and depending on the percent complete column, it locates them more precisely horizontally within that section. It takes the total project value and draws a bubble for its marker, and the bubble size is dependent on how big the project value is, then fills in the color for either low, med, or high risk.

What i would like to do is have the program display the projects in the same way they are currently, but dictate the vertical organization dependent on the GM column value. The range will be fixed, from -10% to +30%.

I have attached screen shots of the list where the information is derived and the chart where the program displays the information, as well as the code.

Thank you very much in advance for your help!!

Code:
Sub TEST() 
    Dim ORDER_V, PHASE, LL, PERCENT, X, Y As Double 
    Dim NAME, PH, RISK As String 
    Application.ScreenUpdating = False 
     
     
    Sheets("Chart").Select 
    Application.DisplayAlerts = False 
    ActiveWindow.SelectedSheets.Delete 
    Application.DisplayAlerts = True 
    Sheets("Chart_Form").Visible = True 
    Sheets("Chart_Form").Copy Before:=Sheets(2) 
    Sheets("Chart_Form (2)").NAME = "Chart" 
    Sheets("Chart_Form").Select 
    ActiveWindow.SelectedSheets.Visible = False 
     
     
    AC_ = ActiveCell.Address 
    Range(Range("A1"), Range("A1").End(xlToRight)).Select 
    ActiveWindow.Zoom = 100 
    Range("A7").Select 
     
     
     
     
    Y = 1 
    LL = 8 
     
     
    Sheets("DB").Select 
    Cells(LL, 3).Select 
     
     
    While ActiveCell.Value <> "" 
        NAME = Cells(LL, 3).Value 
         
         
        PH = Cells(LL, 4).Value 
        If PH = "Contract Nego" Then PHASE = 1 
        If PH = "Permitting" Then PHASE = 2 
        If PH = "Design" Then PHASE = 3 
        If PH = "Manufacturing" Then PHASE = 4 
        If PH = "Installation" Then PHASE = 5 
        If PH = "Commissioning" Then PHASE = 6 
        If PH = "Liability" Then PHASE = 7 
         
         
        PERCENT = Cells(LL, 5).Value 
         
         
        RISK = Cells(LL, 12).Value 
         
         
        ORDER_V = Round(Cells(LL, 18).Value) * 1.5 
         
         
        If ORDER_V > 0 Then 
             
             
            If ORDER_V < 7.5 Then ORDER_V = 7.5 
             
             
            Run Draw_Project(ORDER_V ^ 0.9, PHASE, PERCENT / 100, 1, Y, "" & NAME, RISK) 
            Y = Y + 1 
            If Y > 10 Then 
                Y = 1 
            End If 
        End If 
         
         
        Cells(LL, 3).Select 
        LL = LL + 1 
    Wend 
     
     
    Cells(8, 1).Select 
    Sheets("Currency Lookup").Visible = True 
    ActiveWindow.Zoom = 100 
    Sheets("Chart").Select 
    Application.ScreenUpdating = True 
End Sub 
 
 
Function Draw_Project(R, PHASE, PERC, HScale, Y As Double, NAME, RISK As String) 
    Dim X As Double 
     
     
    If PHASE = 1 Then X = 0 + 138 * PERC 
    If PHASE = 2 Then X = 138 + 140 * PERC 
    If PHASE = 3 Then X = 278 + 140 * PERC 
    If PHASE = 4 Then X = 418 + 140 * PERC 
    If PHASE = 5 Then X = 558 + 140 * PERC 
    If PHASE = 6 Then X = 698 + 139 * PERC 
    If PHASE = 7 Then X = 838 + 125 * PERC 
     
     
    Sheets("Chart").Select 
    ActiveSheet.Shapes.AddShape(msoShapeOval, 31 - R / 2 + X, 156 + (Y - 1) * 54 + 54 / 2 - R / 2, R * HScale, R).Select 
    Selection.ShapeRange.Fill.Visible = msoTrue 
    Selection.ShapeRange.Fill.Solid 
    If RISK = "Low" Then 
        With Selection.ShapeRange.Fill 
            .Visible = msoTrue 
            .ForeColor.RGB = RGB(0, 176, 80) 
            .Transparency = 0 
            .Solid 
        End With 
    End If 
    If RISK = "Med" Then 
        With Selection.ShapeRange.Fill 
            .Visible = msoTrue 
            .ForeColor.RGB = RGB(255, 255, 153) 
            .Transparency = 0 
            .Solid 
        End With 
    End If 
    If RISK = "High" Then 
        With Selection.ShapeRange.Fill 
            .Visible = msoTrue 
            .ForeColor.RGB = RGB(255, 0, 0) 
            .Transparency = 0 
            .Solid 
        End With 
    End If 
    Selection.ShapeRange.Line.Weight = 1 
    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) 
     [COLOR=darkgreen]'Selection.ShapeRange.Shadow.Type = msoShadow5[/COLOR]
     
    If PHASE = 7 Then 
        ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 35 - R / 2 + X - Len(NAME) * 9, 156 + (Y - 1) * 54 + 54 / 2, 0#, 0#).Select 
    Else 
        ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 15 + 9 + R / 2 + X, 156 + (Y - 1) * 54 + 54 / 2, 0#, 0#).Select 
    End If 
    Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue 
    Selection.Characters.Text = NAME 
    With Selection.Font 
        .NAME = "Arial" 
        .Size = 12 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ColorIndex = xlAutomatic 
    End With 
    Selection.Font.Bold = True 
     
     
    Cells(1, 1).Select 
    Sheets("DB").Select 
End Function


attachment.php


attachment.php


-David F
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.

dfelz

New Member
Joined
Nov 18, 2015
Messages
4
Yes, i cross-posted this topic and was not aware of the rules, but i am now and will not make that mistake again.

can anyone tell me how to edit posts on here and also change the status to solved? it was very easy to do on the other sites but not here?
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,139
Hello


  • As you are new here, may I suggest you read the complete set of forum rules, see the link on my signature


  • For a few minutes after posting, one can alter it by clicking “edit post”. When this time elapses, the post author can’t change it anymore


  • I don’t know of a way to formally mark a thread as solved here. You will have to post and type SOLVED.
 

Forum statistics

Threads
1,144,394
Messages
5,724,087
Members
422,536
Latest member
Zeeshan53

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top