Sub Transfert(Wsh_S As Worksheet, Cible As Range)
Const Lgn_Date = 2, First_Col = 3
Dim Tb_Dic, Tb_Det_S, Tb_Res(), Valb
Dim Lgn_Fin As Long, Nb_Lgn As Long, Col_Fin As Long, Nb_Col As Long, _
NbCell As Long, Décal As Long, _
Lgn As Long, col As Long, k As Long, Quart As Double
Application.ScreenUpdating = False
'Nettoyage
With Cible
Lgn_Fin = .EntireColumn.Cells(Parent.Rows.Count).End(xlUp).Row
If Lgn_Fin >= .Row Then .Resize(Lgn_Fin - .Row + 1, 50).Clear
End With
'Dictionaire pour stocker les infos Shift de l'onglet "Tools" (nom, plages horaire, Couleur, motif)
Dim MonDic As New Scripting.Dictionary
' Dim MonDic As Object
' Set MonDic = CreateObject("Scripting.Dictionary")
With MonDic
.CompareMode = 1
.RemoveAll
End With
'tableau de l'onglet "Tools"
Tb_Dic = ThisWorkbook.Worksheets("Tools").[A2:D17].Value
For Lgn = 1 To UBound(Tb_Dic, 1)
MonDic(Tb_Dic(Lgn, 1)) = Tb_Dic(Lgn, 2) & "|" & Format(Tb_Dic(Lgn, 2), "h:mm AM/PM") & "|" & Tb_Dic(Lgn, 3) & "|" & Format(Tb_Dic(Lgn, 3), "h:mm AM/PM") & "|" & Tb_Dic(Lgn, 4)
Next Lgn
'Limites à étudier
Lgn_Fin = Wsh_S.Columns(First_Col).Cells(Wsh_S.Rows.Count).End(xlUp).Row
Col_Fin = Wsh_S.Rows(Lgn_Date).Cells(Wsh_S.Columns.Count).End(xlToLeft).Column
Nb_Col = Lgn_Fin - Lgn_Date + 1
Nb_Lgn = Lgn_Fin - Lgn_Date + 1
'Tableau des données
Tb_Det_S = Wsh_S.Cells(Lgn_Date, First_Col).Resize(Nb_Lgn, Nb_Col).Value2 'Value2 pour pb d'interprétation des dates
'Constitution des résultats
k = 0
For col = 1 To Nb_Col
If IsDate(CDate(Tb_Det_S(1, col))) And Tb_Det_S(1, col) > 1 Then
k = k + 1: ReDim Preserve Tb_Res(1 To k): Tb_Res(k) = Tb_Det_S(1, col)
For Lgn = 2 To Nb_Lgn
If MonDic.Exists(Tb_Det_S(Lgn, col)) Then
If Tb_Det_S(Lgn, col) <> "Vacation" Then
k = k + 1: ReDim Preserve Tb_Res(1 To k): Tb_Res(k) = Tb_Det_S(Lgn, col)
End If
End If
Next Lgn
End If
Next col
'restitution des résultats
Quart = CDbl(TimeValue("0:15:00")) 'pour calculer le nombre de cellules de la plage horaire
With Cible.Resize(k)
.Value = WorksheetFunction.Transpose(Tb_Res) 'Collage de toutes les valeurs
.Borders.LineStyle = xlContinuous 'Bordures
.NumberFormat = "yyyy-mm-dd" 'format date
Tb_Det_S = .Value 'Relecture des résultats (avec les dates en tant que telles)
'Coloration des dates
For Lgn = 1 To k
If IsDate(Tb_Det_S(Lgn, 1)) Then .Cells(Lgn).Interior.Color = 10092543 'si c'est une date mise en couleur
Next
'Barre de couleur correspondant au "Shift"
For Lgn = 1 To k
If MonDic.Exists(Tb_Res(Lgn)) Then
Valb = Split(MonDic(Tb_Res(Lgn)), "|") 'Récupération des données pour ce shift
NbCell = Int((TimeValue(Valb(3)) - TimeValue(Valb(1))) / Quart) 'Nombre de quarts d'heures = nombre de cellule de la barre
Décal = CInt((TimeValue(Valb(1)) - TimeValue("9:45 Am")) / Quart) + 1 'Décalage de la barre
With .Cells(Lgn).Offset(0, Décal)
.Value = "x" 'Valeur x pour l'affichage du format texte
.NumberFormat = ";;;""" & Valb(1) & """* """ & Valb(3) & """" 'Format spécial "Début Fin" sur la barre
.Resize(1, NbCell).Merge 'Fusionner les cellules de la barre
.Interior.Color = Valb(4) 'Couleur de fond
If UBound(Valb) > 4 Then
.Interior.PatternColor = Valb(5) 'Si motif, couleur du motif
.Interior.Pattern = Valb(6) 'si motif, motif choisi
End If
.MergeArea.Borders.LineStyle = xlContinuous 'Bordures autour de la barre
End With
End If
Next Lgn
End With
Application.ScreenUpdating = True
End Sub