Opgelost 2 shapes in 1 regel

[KeBr]

Beste mensen,

Ik ben al enige tijd bezig met een projectplanning is Excel. op dit forum heb ik al veel hulp gekregen. In principe is het ook een werkbaar document gworrden.
Graag wil ik nog ene kleine aanpassing doen, indien er in kolom 3 "fase" staat wordt er u een rechthoek geplaatst. Graag zou ik die rechthoek aan de uiteinde voorzien van omlaag wijzende driehoekjes (punten)
Ik weet waar het in de macro moet (zie vetgedrukt deel hieronder) maar krijg het niet voor elkaar.
In de bijlage heb ik ze geel gemaakt op regel 9, beveiliging van het werkblad is blanco.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ShpNum As String
ww = ""
Sheets("Projectplanning").Unprotect Password:=ww

'Check if E or F date columns and ignore if not
If Intersect(Target, Range("C8:G300")) 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(r, 4) - Cells(6, 5) + 11
RtCell = Cells(r, 6) - Cells(6, 5) + 11


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 Else

'Get date ranges
Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
LftCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(6, 5) + 8
RtCell = Cells(r, 6) + Cells(r, 4) + 1 - Cells(r, 5) + 12
'if "fase" in C then add a rectangle
If Cells(r, 3) = "fase" Then
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left, DtRng.Top + 2, DtRng.Width, DtRng.Height - 10)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc 'FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
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

OnlyONEDate:
Sheets("Projectplanning").Protect Password:=ww

End Sub

 

[snb]

Het is niet verstandig:
- cellen samen te voegen
- wachtwoorden te gebruiken
- onnodig gecompliceerde formules te gebruiken: weeknum(today();21) geeft het ISO-weeknummer
- cellen met voorwaardelijke opmaak te kopiëren: check de overvloed aan voorwaardelijke opmaakregels in het bestand
- figuren te gebruiken voor wat veel eenvoudiger met voorwaardelijke opmaak kan worden gerealiseerd

Wat is de zin van die extra figuurtjes ???

 

[KeBr]

Beste snb,
Dank voor je reactie. om antwoord te geven op je opmerkingen:
- samengevoegde cellen begrijp ik, die heb ik intussen verwijderd
- wachtwoord is noodzakelijk omdat er veel personen mee gaan werken
- de door jou opgegeven formule "weeknum(today();21) werkt niet niet bij mij
- er zit geen overbodige voorwaardelijk opmaak in het document
- de figuren zien er gewoon professioneler uit, de pijlen en andere kan ik niet op dezelfde manier maken met voorwaardelijke opmaak.
- de extra figuurtjes geven iets meer inzicht.

Met wat jij hebt gemaakt in voorwaardelijk opmaak beperkt het gebruik. in mijn geval kan iedere gebruiker nu op het tabblad gegevens zelf namen invullen, die zijn voor elk project anders namelijk.

 

[snb]

Dan werken jullie met een Excel-versie vóór 2010 ?
Met voorwaardelijke opmaak heb je gewoon geen VBA nodig.

 

[KeBr]

Wij werken met office 365.
ik heb het ook nog geprobeerd in een nieuw document. resultaat van de formule is #NAAM

 

[edmoor]

Dan heb je dus een Nederlandse versie van Office en moet je ook de Nederlandse functienamen gebruiken:

=WEEKNUMMER(VANDAAG();21)

 

[snb]

Ik kon het niet laten

 

[KeBr]

Beste snb,

Sorry voor de late reactie. Hetgeen wat jij nu stuurt heb ik zelf reeds eerder gemaakt. Zij het wel dat deze toch weer wat anders is.
Voor de de Projecten waar deze gebruikt gaat worden willen we toch meer het idee van "MS projects" benaderen.
Wat betreft het aanpassen van de macro ben ik er zelf aan uit gekomen. zie onderstaande wat nu op de plaats na het dikgedrukte is gekomen.

Case Else

'Get date ranges
    Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
        LftCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(6, 5) + 8
        RtCell = Cells(r, 6) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    'if "fase" in C then add a rectangle
    If Cells(r, 3) = "fase" Then
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left + 1, 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) + Cells(r, 4) + 1 - Cells(6, 5) + 10
        RtCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    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(r, 4) + 1 - Cells(6, 5) + 10
        RtCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartMerge, Cells(r, LftCell).Left + 3, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width - 4, Cells(r, LftCell).Height - 4)
           NewShp.Fill.ForeColor.RGB = fc
            NewShp.Line.ForeColor.RGB = fc
 
Else

 

[snb]

Al 8 jaar lid en gebruikt nog steeds geen code tags.
Als vormgeving belanrijker is dan functionaliteit kun je beter Photoshop gebruiken.

 

[KeBr]

Beste snb,

Dit is voor het eerst dat er een opmerking gemaakt wordt over code tags. onderstaand alsnog met tags.

Case Else

'Get date ranges
    Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
        LftCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(6, 5) + 8
        RtCell = Cells(r, 6) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    'if "fase" in C then add a rectangle
    If Cells(r, 3) = "fase" Then
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left + 1, 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) + Cells(r, 4) + 1 - Cells(6, 5) + 10
        RtCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    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(r, 4) + 1 - Cells(6, 5) + 10
        RtCell = Cells(r, 5) + Cells(r, 4) + 1 - Cells(r, 5) + 12
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartMerge, Cells(r, LftCell).Left + 3, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width - 4, Cells(r, LftCell).Height - 4)
           NewShp.Fill.ForeColor.RGB = fc
            NewShp.Line.ForeColor.RGB = fc
 
Else