Sous.total selon critère sur liste filtrée

Option Explicit


Function Calcul(Rng As Range, Quoi As String)

  Dim Col As Integer, ColDeb As Integer, NbCol As Integer
  Dim Lig As Long, LigDeb As Long, NbLig As Long
  Dim Tot As Integer, Mem As String
  Application.Volatile
  ' Initialisation des variables
  ColDeb = Rng.Column: NbCol = Rng.Columns.Count
  LigDeb = Rng.Row: NbLig = Rng.Rows.Count
  Tot = 0: Mem = ""
  ' Pour chaque colonne de la plage de cellules
  For Col = ColDeb To ColDeb + NbCol - 1
    ' Pour chaque ligne de la plage de cellules
    For Lig = LigDeb To LigDeb + NbLig - 1
      ' Si la cellule contient le terme cherché
      If Cells(Lig, Col).Value = Quoi Then
        ' On ajoute au total
        Tot = Tot + 1
        ' On mémorise la dernière valeur trouvée
        Mem = Cells(Lig, Col).Value
      ElseIf Cells(Lig, Col).Value <> "" Then
        ' Si la cellule n'est pas vide mais ne correspond pas
        ' On mémorise la dernière valeur trouvée
        Mem = Cells(Lig, Col).Value
      ElseIf Tot >= 1 And IsEmpty(Cells(Lig, Col)) And Mem = Quoi Then
        ' Si le total est >= 1
        ' et que la cellule est vide
        ' mais que la dernière valeur mémorisée correspond
        ' On ajoute au total
        Tot = Tot + 1
      End If
    Next Lig
  Next Col
  ' Renvoyer le total
  Calcul = Tot
End Function