Calculer la durée totale pour 3 conditions

 Option Explicit

Sub CalculeDureeTotalSite()
    Const Cible As String = "K1"
    Dim Str As String, Cause As String, Res()
    Dim LastLig As Long, i As Long, n As Long
    Dim j As Integer
    Dim MonDico As New Scripting.Dictionary
    Dim Tb
    Dim M1 As Integer, M2 As Integer
    Dim MoisNum As Integer, Mn As Integer

    With Feuil1
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Tb = .Range("A2:F" & LastLig)
        For i = 1 To UBound(Tb, 1)

            M1 = Format(Tb(i, 2), "mm")
            M2 = Format(Tb(i, 3), "mm")
            MoisNum = Application.Match(Range("Mois"), Range("ListeMois"), 0)
            [H3].Value = MoisNum
            Cause = Tb(i, 5)
            Application.ScreenUpdating = False

            If (M1 = MoisNum Or M2 = MoisNum) And Cause = "CS" Then
                Str = Tb(i, 1)
                'Pour les sites
                If Not MonDico.Exists(Str) Then
                    MonDico.Add Str, Cause
                Else
                    MonDico(Str) = MonDico(Str) & "," & Cause
                End If
                 End If
        Next i

                n = MonDico.Count
        If n > 0 Then
       
            ReDim Res(1 To n + 1, 1)
            Res(1, 1) = "Site"
      
            For i = 0 To n - 1
                Res(i + 2, 1) = MonDico.Keys(i)
     
                MsgBox "Res(" & i & " + 2, 1) : " & Res(i + 2, 1)
            Next i
            Set MonDico = Nothing
            .Range(Cible).Resize(n + 1) = Res
            .Range(Cible).Resize(n + 1).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlYes
        End If
   End With
    
    '-- Ajout de la formule qui calcul les durées totales pour chaque site
    'AjoutFormule
    
    Application.ScreenUpdating = False
End Sub
Sub AjoutFormule()
    Dim DerLigne As Long
    [L2].FormulaArray = "=SUM((MONTH($B$2:$B$94)<=$H$3)*(MONTH($C$2:$C$94)>=$H$3)*($E$2:$E$94=Cause)" & _
                        "*($A$2:$A$94=K2)*((IF($C$2:$C$94<=DATE(2012,$H$3+1,0),$C$2:$C$94,DATE(2012,$H$3+1,0)))" & _
                        "-(IF($B$2:$B$94>DATE(2012,$H$3,1),$B$2:$B$94,DATE(2012,$H$3,1)))))"
    DerLigne = Cells(Rows.Count, 11).End(xlUp).Row
    [L2].AutoFill Range([L2], Cells(DerLigne, 12))
End Sub

Option Explicit
 
Sub CalculeDureeTotalSite()
Const Cible As String = "K2"
Dim LastLig As Long, i As Long, n As Long, Duree As Double
Dim M1 As Byte, M2 As Byte, MoisNum As Byte
Dim MonDico As New Scripting.Dictionary
Dim Str As String, LaCause As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range(Cible).Resize(LastLig, 2).ClearContents
    Tb = .Range("A2:E" & LastLig)
    LaCause = .[Cause]
    MoisNum = Application.Match(.[Mois], .[ListeMois], 0)
    For i = 1 To UBound(Tb, 1)
        If Tb(i, 5) = LaCause Then
            M1 = Month(Tb(i, 2))
            M2 = Month(Tb(i, 3))
            If Entre(MoisNum, M1, M2) Then
                If M1 < MoisNum Then Tb(i, 2) = DebMois(Tb(i, 2), MoisNum)
                If M2 > MoisNum Then Tb(i, 3) = FinMois(Tb(i, 3), MoisNum)
                Duree = Tb(i, 3) - Tb(i, 2)
                Str = Tb(i, 1)
                If Not MonDico.Exists(Str) Then
                    MonDico.Add Str, Duree
                Else
                    MonDico(Str) = MonDico(Str) + Duree
                End If
            End If
        End If
    Next i
 
    n = MonDico.Count
    If n > 0 Then
        ReDim Res(1 To n, 1 To 2)
        For i = 0 To n - 1
            Res(i + 1, 1) = MonDico.Keys(i)
            Res(i + 1, 2) = MonDico.Items(i)
        Next i
        Set MonDico = Nothing
        .Range(Cible).Resize(n, 2) = Res
        .Range(Cible).Offset(0, 1).Resize(n, 1).NumberFormat = "dd ""jour(s)"" hh"" heure(s) ""mm"" minute(s)"""
        .Range(Cible).Resize(n, 2).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlNo
    End If
End With
End Sub
 
Private Function Entre(ByVal M As Byte, ByVal Mi As Byte, ByVal Mf As Byte) As Boolean
 
Entre = M >= Mi And M <= Mf
End Function
 
Private Function DebMois(ByVal Dte As Long, ByVal M As Byte) As Long
 
DebMois = DateSerial(Year(Dte), M, 1)
End Function
 
Private Function FinMois(ByVal Dte As Long, ByVal M As Byte) As Double
 
FinMois = DateSerial(Year(Dte), M + 1, 1) - 1 / 1440
End Function