Ik heb onderstaande (deel) macro. Deze zorgt voor het plaatsen van shapes met een opgegeven interval.
Hierin zou ik graag zien dat er ook rekening gehouden wordt met werkdagen en feestdagen.
Feestdagen staan op een ander werkblad "feestdagen" (B3:B111)
Case Is = "M" 'Speciale aanduiding voor Meetings of besprekingen
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_"
.Placement = xlMoveAndSize
End With
End If
End If
Next
Case Else
Hierin zou ik graag zien dat er ook rekening gehouden wordt met werkdagen en feestdagen.
Feestdagen staan op een ander werkblad "feestdagen" (B3:B111)
Case Is = "M" 'Speciale aanduiding voor Meetings of besprekingen
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_"
.Placement = xlMoveAndSize
End With
End If
End If
Next
Case Else