I hope someone can help me!

I want that when I enter a value in cell B3 (or B4), the triangle in cell F3 (or J4) moves along. Likewise, when I enter a value in cell C3 (or C4), the triangle in cell J3 (or Q4) will also move. How to program when I have many TASK to do. Thanks.

CodePudding user response：

What you want can be achieved using a Line Chart. No VBA is required.

Here is a basic example.

Disclaimer: This is a very basic example. You will have to modify this to suit your needs.

Let's say you have the dates as shown below in a worksheet.

Follow these steps

1. Enter 1 in the cells G2:L2

2. Select cells G2:L2. Click on Insert tab and insert a Line Chart

3. Delete the gridlines, chart title and the axes of the chart by selecting it.

4. Set the fill as No Fill and border as No Line

5. Select the line and set the marker properties as shown below

6. Right click on the chart and click on Select Data

7. Click on Hidden and Empty cells

8. Select the options as shown in the below dialog box. Click on OK. Click on OK again to close the 2nd dialog box

9. Enter the formula =IFERROR(MATCH(G1,$B$2,0),NA()) in cell G2

10. Enter the formula =IFERROR(MATCH(H1,$B$3,0),NA()) in cell H2 and copy it to the last cell. In our case it is L2. Your worksheet will look like this

11. Change the font color of the cells G2:L2 to white

12. Next enter a start date and the end date. You will notice the line

13. Do the basic formatting and adjust the chart so that the markers are in the center of the cell.

And you are done.

IN ACTION

CodePudding user response：

Okay Admittedly this turned out to be a bit of a mess of a script... but it works.

• Make sure to name all your shapes!!!
• Make sure all the ranges I reference are the same ranges you reference. (easy to fix)

Here is is, make SURE this goes in your worksheet module:

(Or whatever sheet you're using)

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim oTri As Object      'Triangle Object
    Dim oLine As Object     'Line Object
    Dim tLeft As Long       'Left as an integer
    Dim tCell As Range      'Found Value Cell as range
    
    'Used to decide which triangle needs to be updated.
    Select Case Target.Address
        Case "$B$3"     'Design Mode Start Day
            Set oTri = Shapes("LTopTri")
            Set oLine = Shapes("TopLine")
        Case "$C$3"     'Design Mode Finish Day
            Set oTri = Shapes("RTopTri")
            Set oLine = Shapes("TopLine")
        Case "$B$4"     'Manufacture Start Day
            Set oTri = Shapes("LBottomTri")
            Set oLine = Shapes("BottomLine")
        Case "$C$4"     'Manufacture Finish Day
            Set oTri = Shapes("RBottomTri")
            Set oLine = Shapes("BottomLine")
        Case Else
            Exit Sub
    End Select
    
    'Move triangle & Line
    Set tCell = Cells(2, WorksheetFunction.Match(Day(Target.Value), Range("F2:S2"))   5)
    tLeft = tCell.Left   (0.5 * tCell.Width)
    oTri.Top = Target.Top   (0.5 * Target.Height) - (0.5 * oTri.Height)
    oTri.Left = tLeft - (0.5 * oTri.Width)
    oLine.Top = oTri.Top   oTri.Height
    Select Case Target.Row
        Case "3"
            oLine.Left = Shapes("LTopTri").Left   (0.5 * Shapes("LTopTri").Width)
            oLine.Width = Shapes("RTopTri").Left - Shapes("LTopTri").Left
        Case "4"
            oLine.Left = Shapes("LBottomTri").Left   (0.5 * Shapes("LBottomTri").Width)
            oLine.Width = Shapes("RBottomTri").Left - Shapes("LBottomTri").Left
    End Select
    
End Sub

Shape Names:

Result Examples: