Private Sub Worksheet_Change(ByVal Target As Range)
Dim ShpNum As String
Dim Dupl As Shape, NewShp As Shape
Sheets("Projectplanning").Unprotect Password:=Wachtwoord()
'Controleer of E, F en I datumkolommen zijn. zo niet sla dan over.
If Intersect(Target, Range("C8:I300")) Is Nothing Then Exit Sub 'Edit 8 & or 300 if inappropriate
'Check if more than one cell and ignore if yes
If Target.Count > 1 Then Exit Sub
'Otherwise...
r = Target.Row
' ignore if an empty Column C in row
If Cells(r, 7) = "" Then Exit Sub
'otherwise a date has been changed
ShpName = "SHP_" & Cells(r, 7) 'Shape Name
'Delete current shape of that name if it exists
For Each xshape In Shapes
If xshape.TopLeftCell.Row = Target.Row Then xshape.Delete
Next
'get equal date cells
LftCell = Cells(r, 5) - Cells(6, 5) + 18
RtCell = Cells(r, 6) - Cells(6, 5) + 18
x = Application.Match(Cells(r, 3), Sheets("Gegevens").Columns(5), 0)
If IsNumeric(x) Then fc = RGB(Sheets("Gegevens").Cells(x, 6), Sheets("Gegevens").Cells(x, 7), Sheets("Gegevens").Cells(x, 8))
Select Case Cells(r, 7).Value
Case Is <= 0
'diamond for Milestone date
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeDiamond, Cells(r, LftCell).Left, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width, Cells(r, LftCell).Height - 4)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc
Case Is = "M" 'Speciale aanduiding voor Meetings
ActiveCell.Offset(-1, 0).Select
On Error Resume Next
For d1 = Application.InputBox("geef startdatum", Type:=1) To Application.InputBox("geef einddatum", Type:=1) Step InputBox("geef interval") 'ergens een gek interval opzetten = om de 3 dagen
r = Application.Match(d1, ActiveSheet.Rows(6), 0) 'zoek die dag op in de rij 6
If IsNumeric(r) Then 'gevonden
Set C = ActiveSheet.Cells(ActiveCell.Row, r) 'in deze cel komt je shape
If NewShp Is Nothing Then 'het is de eerste shape
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRightTriangle, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2) 'beginshape
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc
NewShp.Name = "SHP_"
Else
Set Dupl = Nothing
Set Dupl = NewShp.Duplicate 'eerste shape dupliceren
DoEvents
With Dupl 'die shape
.Left = C.Left + 1 'verplaatsen
.Top = C.Top + 1
.Width = C.Width - 2 'vorm aanpassen
.Height = C.Height - 2
.Name = "SHP_"
End With
End If
End If
Next
Case Else
'Get date ranges
Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
LftCell = Cells(r, 5) + 1 - Cells(6, 5) + 8
RtCell = Cells(r, 6) + 1 - Cells(r, 5) + 12
'if "fase" in C then add a rectangle
If Cells(r, 3) = "Fase" Or Cells(r, 3) = "Project" Then
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left + 2, DtRng.Top + 2, DtRng.Width - 10, DtRng.Height - 10)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc 'FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
LftCell = Cells(r, 5) + 1 - Cells(6, 5) + 17
RtCell = Cells(r, 5) + 1 - Cells(r, 5) + 19
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartMerge, Cells(r, LftCell).Left + 1, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width - 5, Cells(r, LftCell).Height - 4)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc
Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
LftCell = Cells(r, 6) - Cells(6, 5) + 18
RtCell = Cells(r, 5) + 1 - Cells(r, 5) + 19
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartMerge, Cells(r, LftCell).Left + 4, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width - 5, Cells(r, LftCell).Height - 4)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc
Else
'Otherwise if text in C add arrow bar
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, DtRng.Left, DtRng.Top + 3, DtRng.Width, DtRng.Height - 6)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc 'FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
End If
End Select
'Name shape as per value
NewShp.Name = ShpName
Sheets("Projectplanning").Protect Password:=Wachtwoord()
End Sub
