Inserting a shape based on multiple excel values?

[HelpMeWithExcelPlease]

I am creating a Gantt chart and one of the last steps is getting a view of milestones on my Gantt. For this I would like to insert a shape whenever column C has a value, "Yes" and then place the shape on the row based on the date entered in column E.

Here is what my sheet looks like so far, with the Gantt view on the right hand side of the table, using conditional formatting to fill in for the length of the tasks:

ID

Description

Milestone?

Start

End

3/1

3/2

3/3

3/4

3/5

3/6

3/7

3/8

1

Regression Testing

3/1/2018

3/3/2018

2

Project Go Live

Yes

3/2/2018

3/2/2018

3

Sprint 3

3/5/2018

3/8/2018

4

Conversion

Yes

3/7/2018

3/7/2018

<tbody>
</tbody>

My question is on how I would go about writing vba code to have a shape inserted into the right cell if column C had a value "Yes" and then the shape would be placed on that row based on the End date in column E. Any ideas?

Your suggestions and direction are greatly appreciated, thank you!

 

[PatOBrien198]

Try something like this....

You may need to adjust the height and width of the shape (set to 15 in the code below) to get it to fit in the cell.

Sub DoIt()

Dim rngStart As Range
Dim r As Long
Dim dte1 As Date
Dim rngToFind As Range
Dim sh As Shape
Dim sngLeft As Single
Dim sngTop As Single
Dim sngHeight As Single
Dim sngWidth As Single
'remove all shapes
For Each sh In ActiveSheet.Shapes
    If Left(sh.Name, 7) = "5-Point" Then
        sh.Delete
    End If
Next
Set rngStart = ActiveSheet.Range("A1")
r = 1
Do While rngStart.Offset(r, 0) <> ""
    If rngStart.Offset(r, 2) = "Yes" Then
        dte1 = rngStart.Offset(r, 4)
        Set rngToFind = ActiveSheet.Rows("1:1").Find(what:=dte1)
        If Not rngToFind Is Nothing Then
            sngWidth = 15
            sngHeight = 15
            sngLeft = rngToFind.Left + rngToFind.Width / 2 - sngWidth / 2
            sngTop = rngStart.Offset(r, 0).Top + rngStart.Offset(r, 2).Height / 2 - sngHeight / 2
            ActiveSheet.Shapes.AddShape(msoShape5pointStar, sngLeft, sngTop, sngWidth, sngHeight).Select
        Else
            MsgBox "End Date not found in top row"
        End If
    End If
    r = r + 1
Loop
Range("A1").Select
End Sub

 

[HelpMeWithExcelPlease]

Hey Pat, thanks for the quick response. How exactly would I insert this into my excel? I don't have any prior experience with excel. I know I would need to open the code view from my worksheet, but beyond that step I am fairly lost. Could you (or anyone else) provide some more context?

Thanks!

 

[PatOBrien198]

Start by opening the Code window, as you said: Alt + F11
Right click on or under the name of your workbook in the Project window (usually top left)
Click "Insert", then select "Module"
Copy and paste the code above to the Code window.
You can rename your module in the Properties window (usually bottom left)

Then, back on your worksheet, insert a shape - other than a 5-pointed star (because the code deletes all 5 pointed stars, then recreates them),
This will be used as a button to run the code (I usually pick a rounded rectangle for my buttons)
Right click the rectangle and select "Assign Macro"
Pick the name of the macro you just copied to the code window.
If you want to (FIRST) rename the macro from "DoIt" to something more of your liking.... Sub AddStarsAtMilestoneDates() for example.

Hope this helps.

 

[HelpMeWithExcelPlease]

Thanks Pat! I was able to put the code in the Module, but am still trying to figure out just how I can get it to add shapes whenever Column C is "Yes", and have the shape be placed on the date column that corresponds to the End Date in Column E. Are there edits to the code that you provided that I need to make in order for it to create shapes based on those criteria?

Thanks again for your assistance!

 

[PatOBrien198]

The line of code :

If rngStart.Offset(r, 2) = "Yes" Then

checks for column C (offset starts at column A and for each row (r) checks the column to the right 2 columns (C).

 

[HelpMeWithExcelPlease]

I've put in the code in the appropriate module and inserted the button to run the code, but whenever I run it I am moved to cell A1 an no shapes are inserted. I've tried to read through the code to understand if there are any edits I need to make to it to fit it to my actual sheet, but so far I am unable to come up with any answers. At the link below is essentially a copy of my table - I have not changed anything in the code that was originally posted, but when I run it two things happen:

1. If there are any 5-pointed start shapes they are deleted
2. My selection moves to cell A1
3. No shapes are inserted, even on the rows where they should be

Example of my table:

https://ibb.co/ebm7Fx

Any ideas on what I need to do to make this work? My other option is to go in and manually insert the milestones, and I'm hoping to avoid that very manual tasks as I have ~200 milestones and their dates are not 100% solidified at this point.

Any help on this is greatly appreciated! Thank you in advance!

 

[PatOBrien198]

Try stepping thru the code (select anywhere in the subroutine and start hitting F8)

Then on each line that it executes, you can hover over the variables and the values will be displayed.

It sounds like the line:
If rngStart.Offset(r, 2) = "Yes" Then
is not finding any cells in the C column that have "Yes" until it finds an empty cell.

Upon further looking, it looks like your data starts in row 7..

so:
Set rngStart = ActiveSheet.Range("A1")

should be

Set rngStart = ActiveSheet.Range("A7")

The macro will then work it's way down the A column until an empty space is found.

If you have intentional blank rows, then something slightly different will have to be done.


Also, your dates are in the 5th row, rather than the first row, so....

Set rngToFind = ActiveSheet.Rows("1:1").Find(what:=dte1)

will have to be changed to:

Set rngToFind = ActiveSheet.Rows("5:5").Find(what:=dte1)