Option Explicit
Sub VerlofkalenderOpstellen()
'==============================================
'hier aanpassen indien nodig
Const sSource As String = "Blad1"
Const sTarget As String = "Blad2"
Const sSourceBeginCell As String = "A4"
Const sVerlof1 As String = "VL-S1"
Const sVerlof2 As String = "VL-S2"
Const sVerlof3 As String = "VL-S3"
'==============================================
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rNames As Range
Dim rTemp As Range
Dim rDagen As Range
Dim lMax As Long
Dim iKolomHeader As Integer
Dim lRij1 As Long
Dim lRij2 As Long
Dim lRij3 As Long
Application.ScreenUpdating = True
Set wsSource = ThisWorkbook.Sheets(sSource)
Set wsTarget = ThisWorkbook.Sheets(sTarget)
With wsTarget.Range("B1")
.Offset(0, 0).Value = sVerlof1
.Offset(0, 2).Value = sVerlof2
.Offset(0, 4).Value = sVerlof3
End With
lRij1 = 1
lRij2 = 1
lRij3 = 1
lMax = 1
For Each rNames In wsSource.Range(sSourceBeginCell, wsSource.Range(sSourceBeginCell).End(xlDown))
Application.StatusBar = "Bezig met " & rNames.Value & String(3, ".")
wsTarget.Cells(lMax + 1, 1).Value = rNames.Value
On Error Resume Next
Set rDagen = wsSource.Range("B" & rNames.Row, "CT" & rNames.Row).SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo 0
If Not rDagen Is Nothing Then
For Each rTemp In rDagen
Select Case rTemp.Value
Case sVerlof1:
lRij1 = lRij1 + 1
iKolomHeader = 1
Case sVerlof2:
lRij2 = lRij2 + 1
iKolomHeader = 2
Case sVerlof3:
lRij3 = lRij3 + 1
iKolomHeader = 3
End Select
wsTarget.Cells(Choose(iKolomHeader, lRij1, lRij2, lRij3), 2 * iKolomHeader).Value = wsSource.Cells(1, rTemp.Column).Value
Next rTemp
End If
lMax = Application.Max(lRij1, lRij2, lRij3)
lRij1 = lMax
lRij2 = lMax
lRij3 = lMax
Next
With wsTarget
.Columns(1).Font.Bold = True
.Rows(1).Font.Bold = True
' .Range("B1").EntireColumn.Delete
' .Range("D1").EntireColumn.Delete
.Cells.EntireColumn.AutoFit
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
