Sub SnakeLine()
Dim Cel As Range
Dim CelHt As Single
Dim CelLeft As Single
Dim CelWid As Single
Dim CelRt As Single
Dim CelTop As Single
Dim CelBot As Single
Dim CelMidVert As Single
Dim CelMidHorz As Single
Dim PercVar As Single
Dim LastPercVar As Single
Dim LastNode2X As Single
Dim LastNode2Y As Single
Dim Node1X As Single
Dim Node1Y As Single
Dim Node2X As Single
Dim Node2Y As Single
Dim Shp As ShapeRange
Dim Sht As Worksheet
Dim X As Long
Dim Rw As Long
Dim RevDate As Date
Dim DateHdrs As Range
Dim ThisDateHdr As Range
Dim PercVarCol As Range
Dim SnakeCol As Range
Dim GanttArea As Range
Dim SchedTypeCol As Range
Dim PV As Variant
Set Sht = Sheets("Gantt")
Set DateHdrs = Sht.Range("DateHeaders")
Set PercVarCol = Sht.Range("PercVarCol")
Set GanttArea = Sht.Range("GanttArea")
Set SchedTypeCol = Sht.Range("SchedTypeCol")
RevDate = Sht.Range("ReviewDate").Value
'Find the date over the Gantt Area that matches the Review Date and then set the column for line insertion
For Each Cel In DateHdrs
If RevDate >= Cel.Value And RevDate <= Cel.Value + 6 Then
Set ThisDateHdr = Cel
Set SnakeCol = Intersect(GanttArea, Cel.EntireColumn)
Exit For
End If
Next Cel
For X = Sht.Shapes.Count To 1 Step -1
If Left(Sht.Shapes(X).Name, 3) = "Row" Then
'Debug.Print Sht.Shapes(X).Name
Sht.Shapes(X).Delete
End If
Next X
For Each Cel In SnakeCol
If Intersect(SchedTypeCol, Cel.EntireRow).Value = "Plan" Then 'Only work the Plan Rows
PV = Intersect(PercVarCol, Cel.Offset(1, 0).EntireRow).Value
If PV <> "" Then
PercVar = PV
CelLeft = Cel.Left
CelWid = Cel.Width
CelTop = Cel.Offset(1, 0).Top
CelMidHorz = CelLeft + (CelWid / 2)
Rw = Cel.Row
If LastNode2Y = 0 Then
Node1Y = Cel.Top
Else
Node1Y = LastNode2Y
End If
If LastNode2X = 0 Then
Node1X = CelMidHorz
Else
Node1X = LastNode2X
End If
Node2Y = CelTop
Node2X = CelLeft + ((CelWid * PercVar) / 2)
X = X
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Node1X, Node1Y, Node2X, Node2Y).Select
Set Shp = Selection.ShapeRange
'Debug.Print Shp.ID
Shp.Name = "Row" & Rw
With Shp.Line
.Visible = msoTrue
.Weight = 1.75
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
LastNode2X = Node2X
LastNode2Y = Node2Y
End If
End If
Next Cel
ThisDateHdr.Select
End Sub
