Function Quantite(Plage As Range, ByVal Quoi As String)
Dim x, i&, s, n&
Quoi = SansAccent(Quoi)
For Each x In Plage: n = n + Combien(SansAccent(x), Quoi): Next x
If n > 0 Then Quantite = n Else Quantite = vbNullString
End Function
Function Combien(ByVal Dans As String, ByVal Quoi As String) As Long
Dim i&, s, n&
Quoi = LCase(Application.Trim(SansPlurielenS(Quoi)))
s = EclaterCmde(Dans)
For i = LBound(s) To UBound(s)
s(i) = LCase(Application.Trim(SansPlurielenS(s(i))))
If Not (Left(s(i), 1) >= "1" And Left(s(i), 1) <= "9") Then s(i) = "1 " & s(i)
If s(i) = Quoi Then n = n + 1
Next i
Combien = n
End Function
Function EclaterCmde(ByVal x As String)
EclaterCmde = Split("0+ " & Application.Trim(LCase(x)), "+")
End Function
Function SansPlurielenS(ByVal x As String)
Dim i&, s
s = Split(x)
For i = LBound(s) To UBound(s)
If LCase(Right(s(i), 1)) = "s" Then s(i) = Left(s(i), Len(s(i)) - 1)
Next i
SansPlurielenS = Join(s)
End Function
Function SansAccent(ByVal x)
Const lettresAvec = "Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ"
Const lettresSans = "Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,n,o,o,o,o,o,u,u,u,u,y,y"
Dim i&, j&
For i = 1 To Len(x)
j = InStr(lettresAvec, Mid(x, i, 1))
If j > 0 Then x = Replace(x, Mid(x, i, 1), Mid(lettresSans, j, 1))
Next i
x = Replace(x, UCase("œ"), "OE"): x = Replace(x, "œ", "oe")
x = Replace(x, UCase("æ"), "AE"): x = Replace(x, "æ", "ae")
SansAccent = x
End Function
, 
