Option Explicit
Const InterPoste = 15 ' durée minimale entre la libération d'un poste
' et la prise en main d'un autre poste
' la durée est exprimée en minute.
Sub Reperer_Doublon()
Const Source = "Feuil1"
Dim derlig&, dercol&, t, i&, ii&, j&, jj&, nomOp$
Application.ScreenUpdating = False
' lecture des données - tableau t
Worksheets(Source).Select
derlig = Cells(Rows.Count, "b").End(xlUp).Row + 1 '(une ligne en plus !!! )
dercol = Cells(1, Columns.Count).End(xlToLeft).Column + 4
t = Range("a1").Resize(derlig, dercol).Value
'on "décolore les données sources"
Range("a2").Resize(derlig, dercol).Interior.ColorIndex = xlColorIndexNone
Range("a2").Resize(derlig, dercol).Font.Color = vbBlack
' dans le tableau, on normalise les noms (minuscule)
' et on ajoute la date aux heures [heure <- date + heure]
For i = 3 To UBound(t)
For j = 5 To UBound(t, 2) Step 5
t(i, j - 2) = Trim(LCase(t(i, j - 2))) 'normalisation du nom
If t(i, j - 2) <> "" And t(i, j) <> "" And t(i, j + 2) <> "" Then
'nom et horaires non vides, on continue
If IsDate(t(i, 2)) And IsNumeric(t(i, j)) And IsNumeric(t(i, j + 2)) Then
' à priori la date et l'horaire de début et de fin existent
' on va rajouter la date aux heures
If t(i, j + 2) >= t(i, j) Then
'l'heure de fin est supérieure ou égale à l'heure de début (même jour)
t(i, j) = t(i, 2) + t(i, j)
t(i, j + 2) = t(i, 2) + t(i, j + 2)
Else
' l'heure de fin est inférieure à l'heure de début
' on rajoute un jour à l'heure de fin
t(i, j) = t(i, 2) + t(i, j)
t(i, j + 2) = t(i, 2) + 1 + t(i, j + 2)
End If
Else
'date ou horaires incorrects, le nom est mis à vide
t(i, j - 2) = Empty
End If
Else
'date ou horaires incorrects, le nom est mis à vide
t(i, j - 2) = Empty
End If
Next j
Next i
'on vide la dernière ligne
For j = 1 To UBound(t, 2): t(UBound(t), j) = Empty: Next
' pour chaque plage d'une ligne, on regarde si l'opérateur correspondant
' n'a pas une autre plage qui la chevauche. (on regarde dans la ligne plus la suivante)
For i = 3 To UBound(t) - 1
For j = 5 To UBound(t, 2) Step 5
nomOp = t(i, j - 2)
If nomOp <> "" Then 'le nom de l'opérateur ne doit pas être vide
'on regarde les autres plages du même opérateur en excluant la plage en cours
For ii = i To i + 1
For jj = 5 To UBound(t, 2) Step 5
' on exclut la plage de référence en cours de l'opérateur
' les noms doivent être identiques
If Not (ii = i And jj = j) And t(ii, jj - 2) = nomOp Then
If Chevauchement(t(i, j), t(i, j + 2), t(ii, jj), t(ii, jj + 2), InterPoste) Then
Range(Cells(i, j - 2), Cells(i, j + 2)).Interior.Color = vbYellow
Range(Cells(i, j - 2), Cells(i, j + 2)).Font.Color = vbRed
Range(Cells(ii, jj - 2), Cells(ii, jj + 2)).Interior.Color = vbYellow
Range(Cells(ii, jj - 2), Cells(ii, jj + 2)).Font.Color = vbRed
End If
End If
Next jj
Next ii
End If
Next j
Next i
End Sub
Function Chevauchement(x0, y0, x1, y1, DureeInterPoste) As Boolean
Dim interv0, interv1
'interv0 est la plage dont le début est le plus petit
If x0 <= x1 Then
interv0 = Array(x0, y0): interv1 = Array(x1, y1)
Else
interv0 = Array(x1, y1): interv1 = Array(x0, y0)
End If
'on tient compte de la durée entre deux postes
Chevauchement = interv1(0) < interv0(1) + DureeInterPoste / 1440
End Function
.
