Chevauchement d'heures pour plusieurs jours et par noms

Bonjour à tous,

Je soumets mon problème excel car je ne trouve pas la solution :

Le fichier joint sera plus explicite, mais je vais tenter d'expliquer ce que je souhaiterais obtenir :

Pour chaque ligne du tableau, je voudrais savoir s'il y a un chevauchement d'activité pour les usagers concernés de cette ligne sur l'ensemble du mois,

Merci d'avance pour vos solutions,

Cordialement,

Bonjour Massari.

Voici un code fonctionnant :

Sub chevauchement()
Dim aC(), a(), i&
a = Sheets("Feuil2").[a1].CurrentRegion.Value
ReDim aC(1 To UBound(a) - 2) '-2 car deux colonnes d'en-tête.
For i = UBound(a) - 1 To LBound(a) + 2 Step -1
    If a(i, 2) = a(i + 1, 2) And a(i, 5) = a(i + 1, 5) Then
        aC(i - 1) = "Chevauchement"
        aC(i - 2) = "Chevauchement"
    End If
Next i
Sheets("Feuil2").[I3].Resize(UBound(aC)).Value = Application.Transpose(aC)
End Sub

Bonjour Thebenoit59,

Merci pour le code, je crois cependant qu'il ne tient pas compte des plages horaires différentes qui se chevauchent.

J'ai l'impression qu'il compare les dates début et fin + le nom usager et s'il trouve exactement les mêmes conditions, alors le code va mettre chevauchement.

Je joins le fichier avec la macro que tu as préparé pour mieux illustré mes propos,

Cordialement,

Et avec ce code :

Sub chevauchement2()
Dim aC(), a(), i&
a = Sheets("Feuil2").[a1].CurrentRegion.Value
ReDim aC(1 To UBound(a) - 2) '-2 car deux colonnes d'en-tête.
For i = UBound(a) - 1 To LBound(a) + 2 Step -1
    If ((a(i, 2) <= a(i + 1, 2) And a(i, 2) >= a(i + 1, 1)) Or (a(i, 1) <= a(i + 1, 2) And a(i, 1) >= a(i + 1, 1))) And verifUsager(a(i + 1, 5), a(i, 5)) Then
        aC(i - 1) = "Chevauchement"
        aC(i - 2) = "Chevauchement"
    End If
Next i
Sheets("Feuil2").[I3].Resize(UBound(aC)).Value = Application.Transpose(aC)
End Sub

Function verifUsager(n, n1) As Boolean
Dim temp1, temp2
verifUsager = False
If n1 = "" Or n = "" Then Exit Function
temp1 = Split(n, ",")
temp2 = Split(n1, ",")
For i = LBound(temp2) To UBound(temp2) - 1
    For j = LBound(temp1) To UBound(temp1) - 1
        If temp2(i) = temp1(j) Then verifUsager = True: Exit Function
    Next j, i
End Function

Génial

Je vais voir à l'usage mais je pense que c'est bon !!!!

Merci beaucoup !

Cordialement,

Bonjour Thebenoit59,

Pourriez vous m'expliquer votre code?,

Merci d'avance,

Cordialement,

Sub chevauchement2()
Dim aC(), a(), i&
'Enregistrement de ton tableau existant dans un tableau virtuel.
a = Sheets("Feuil2").[a1].CurrentRegion.Value
'Redimensionnement du tableau "Chevauchement" avec deux lignes de moins.
ReDim aC(1 To UBound(a) - 2) '-2 car deux colonnes d'en-tête.
'Boucle du tableau original.
For i = UBound(a) - 1 To LBound(a) + 2 Step -1
    'Si l'heure de fin ou de début est comprise entre l'heure du début et de fin de la ligne d'après ET que l'usager est le même
    If ((a(i, 2) <= a(i + 1, 2) And a(i, 2) >= a(i + 1, 1)) Or (a(i, 1) <= a(i + 1, 2) And a(i, 1) >= a(i + 1, 1))) And verifUsager(a(i + 1, 5), a(i, 5)) Then
        'Inscription du Chevauchement dans la ligne du second tableau.
        aC(i - 1) = "Chevauchement"
        'Idem pour la ligne suivante.
        aC(i - 2) = "Chevauchement"
    End If
Next i
'Transposition du tableau chevauchement à partir de I3.
'Resize augmente la zone du nombre de lignes du tableau chevauchement
Sheets("Feuil2").[I3].Resize(UBound(aC)).Value = Application.Transpose(aC)
End Sub

Function verifUsager(n, n1) As Boolean
Dim temp1, temp2
'Passage du booléen à faux (pas le même usager)
verifUsager = False
'Si l'usager de la ligne ou de la ligne suivante est vide alors quitte la fonction.
If n1 = "" Or n = "" Then Exit Function
'Découpe les usagers à chaque virgule.
temp1 = Split(n, ",")
temp2 = Split(n1, ",")
'Boucle les listes d'usagers de la ligne en cours et la ligne suivante.
For i = LBound(temp2) To UBound(temp2) - 1
    For j = LBound(temp1) To UBound(temp1) - 1
        'S'il trouve le même usager sur les deux lignes passage à Vrai et quitte la fonction.
        'Pas la peine de continuer la boucle, il y a dans tous les cas un chevauchement.
        If temp2(i) = temp1(j) Then verifUsager = True: Exit Function
    Next j, i
End Function

Merci pour la description du code,

Cependant si il y un chevauchement mais pas sur la ligne du dessous mais celle d’après cela va fonctionné.?

02/10/2017 16:00 02/10/2017 17:30 90 MEURDESOIF Yoan, VERNAGUT Matheo,

02/10/2017 15:45 02/10/2017 16:00 15 TMEURDESOIF Yoan,

Pourrais tu me dire ce que je dois modifier?,

Cordialement,

Dans les conditions j'ai mis =< ou >= joue dessus.

Non ça ne fonctionne pas si c'est sur la ligne d'encore après.

je dois donc enlever les signes = ?,

Par contre c'est possible de le faire sur toutes les lignes la comparaison de l'indication chevauchement? ou ce serait un code trop long?

Merci pour ton aide,

Cordialement,

Ca serait beaucoup trop long je trouve.

Tu supprimes le = quand tu compares l'heure du début avec l'heure de fin de la ligne suivante.

Donc les 4 "=" lol

J'ai beaucoup de mal comme tu peux voir !

Cordialement,

J'ai supprimé le premier et le troisième, je pense que c'est ces deux la !

Pourrais tu me confirmer,

Merci d'avance,

Non pas les 4.

    If ((a(i, 2) <= a(i + 1, 2) And a(i, 2) > a(i + 1, 1)) Or (a(i, 1) < a(i + 1, 2) And a(i, 1) >= a(i + 1, 1))) And verifUsager(a(i + 1, 5), a(i, 5)) Then

En supprimant le premier et le troisième égal cela me donnait le même résultat, mais je suis donc ta modif.

Vous allez dire que j'en demande beaucoup mais c'est pas possible de le faire pour toutes les lignes le décompte du chevauchement?,

Merci pour votre aide,

Cordialement,

En fait je ne comprends pas trop l'intérêt de vérifier toutes les lignes.

Si tes données sont triées normalement tu ne devrais pas avoir de soucis.

Ok merci beaucoup,

Je verrais à l'usage mais je pense que ce devrait le faire car effectivement l'extraction des données est triée par les dates de début et les usagers également,

Encore merci,

Cordialement,

Procédure de détection des chevauchements et constitution d'un tableau autonome des chevauchements (pour ordre et recherches ultérieures).

Function ConverTemps(dh As String) As Double
    Dim dhc
    dhc = Split(dh)
    ConverTemps = CLng(DateValue(dhc(0))) + TimeValue(dhc(1))
End Function

Sub Chevauchements()
    Dim dUsa As Object, dAct As Object, k, itm, no%, u%, n%, i%
    Dim Tmp(), Tch(), ch%
    Set dUsa = CreateObject("Scripting.Dictionary")
    Set dAct = CreateObject("Scripting.Dictionary")
    'Recueil données: dico Usagers (nb activ. recensées), dico Activités-Usagers (horodatage, activité, encadrants)
    With ActiveSheet
        n = .Cells(.Rows.Count, 5).End(xlUp).Row
        For i = 3 To n
            If .Cells(i, 5) <> "" Then
                itm = Array(ConverTemps(.Cells(i, 1)), ConverTemps(.Cells(i, 2)), .Cells(i, 4), .Cells(i, 7))
                k = Split(.Cells(i, 5), ",")
                For u = 0 To UBound(k) - 1
                    k(u) = Trim(k(u)): no = dUsa(k(u)) + 1
                    dUsa(k(u)) = no: k(u) = k(u) & "-" & no
                    dAct(k(u)) = itm
                Next u
            End If
        Next i
    End With
    'Traitement par Usager
    For Each k In dUsa.keys
        u = CInt(dUsa(k))
        'Tableau Activités (horodatages, activités, encadrants) de l'Usager
        ReDim Tmp(3, u)
        For no = 1 To u
            itm = dAct(k & "-" & no)
            For i = 0 To 1
                Tmp(i, no) = Val(Replace(itm(i), ",", "."))
                Tmp(i + 2, no) = itm(i + 2)
            Next i
        Next no
        'Tri tableau par horodatage début Activité (croissant)
        For no = 1 To u - 1
            For n = no + 1 To u
                If Tmp(0, n) < Tmp(0, no) Then
                    For i = 0 To 3
                        Tmp(i, 0) = Tmp(i, n)
                        Tmp(i, n) = Tmp(i, no)
                        Tmp(i, no) = Tmp(i, 0)
                    Next i
                End If
            Next n
        Next no
        'Comparaison horodatage début Activité à fin Activité précédente
        'Si chevauchement, insertion données (Usager, horodatages, activités, encadrants) dans Tableau Chevauchements
        For no = 2 To u
            If Tmp(0, no) < Tmp(1, no - 1) Then
                ReDim Preserve Tch(8, ch)
                Tch(0, ch) = k
                For i = 0 To 3
                    Tch(i + 1, ch) = Tmp(i, no - 1)
                    Tch(i + 5, ch) = Tmp(i, no)
                Next i
                ch = ch + 1
            End If
        Next no
    Next k
    'Affichage Tableau Chevauchements
    With Worksheets.Add(after:=ActiveSheet)
        With .Range("A3").Resize(ch, 9)
            .Value = WorksheetFunction.Transpose(Tch)
            .NumberFormat = "dd/mm/yyyy hh:mm"
            .Columns.AutoFit
            .Borders.Weight = xlThin
        End With
        itm = Split("Usager;Début activ.(1);Fin activ.(1);Activité (1);Encadrants (1);Début activ.(2);" _
         & "Fin activ.(2);Activité (2);Encadrants (2)", ";")
        With .Range("A2:I2")
            .Value = itm
            .HorizontalAlignment = xlCenter
            .Font.Italic = True
        End With
        With .Range("A1")
            .Value = "Chevauchements d'activités détectés"
            .HorizontalAlignment = xlCenter
            With .Font
                .Size = 14: .Bold = True
            End With
        End With
        .Range("A1:I1").Merge
        .Activate
    End With
End Sub

Bonjour Mr Ferrand, bonjour à tous.

Je ressors ce post car je souhaiterais le même tableau mais cette fois ci pour déterminer les chevauchements non plus par usagers mais par encadrants ...

Qui pourrait adapter la macro a ce que je souhaite ?

Merci pour votre aide 😉

Hello massari

je présume que MFerrand a un (très) gros soucis

je veux bien reprendre, mais avec une autre méthode

je crée 2 base de données triées et j'affiche les chevauchements par une MFC

Merci beaucoup ... je regarde le fichier cette semaine et reviendrais sur le post pour confirmer ou non si cest ok ... Merci d'avance pour le travail effectué 😊 ...Mr Ferrand n'étant plus svt connecté j'espère que ca va pour lui ... bonne soirée à vs