Option Explicit
'
Function Récap(ByVal PlgK As Range, ParamArray PV() As Variant) As Variant
Dim PlgA As Range, K As Variant, TbIndex() As Long, P As Long, Ls As Long, N As Long, Le As Long, _
TSrcS() As Variant, Nbr As Long, Fini As Boolean ', TSom() As Double, TRés() As Variant
On Error GoTo Erreur
Rem. —— Indexation
K = PlgK.Value
With New Indexeur: .Init TbIndex, 1, UBound(K, 1): While .Actif: .ASupB = K(.A, 1) > K(.B, 1): Wend: End With
Set PlgA = Application.Caller
ReDim TRés(1 To PlgK.Rows.Count, 1 To PlgA.Columns.Count) As Variant
Rem. —— Paramètres supplémentaires
ReDim TSrcS(2 To UBound(TRés, 2)) As Variant
ReDim TSom(2 To UBound(TRés, 2)) As Double
For P = 0 To UBound(PV)
Select Case TypeName(PV(P))
Case "String": TSrcS(P + 2) = "N"
Case "Range": TSrcS(P + 2) = Intersect(PV(P).EntireColumn, PlgK.EntireRow).Value
Case Else: MsgBox "Paramètre " & P + 2 & " non géré", vbExclamation, "Récap"
End Select
Next P
Rem. —— Parcours par ordre croissant
Ls = 1: N = 1: Le = TbIndex(1)
Do: TRés(Ls, 1) = K(Le, 1): Nbr = 1
For P = 2 To UBound(TSrcS)
If IsArray(TSrcS(P)) Then If IsNumeric(TSrcS(P)(Le, 1)) Then TSom(P) = TSrcS(P)(Le, 1) Else TSom(P) = 0
Next P
Do: N = N + 1: Fini = N > UBound(TbIndex): If Fini Then Exit Do
Le = TbIndex(N): If K(Le, 1) <> TRés(Ls, 1) Then Exit Do
For P = 2 To UBound(TSrcS)
If IsArray(TSrcS(P)) Then If IsNumeric(TSrcS(P)(Le, 1)) Then TSom(P) = TSom(P) + TSrcS(P)(Le, 1)
Next P
Nbr = Nbr + 1
Loop
Rem. —— Épilogue
If Ls - 1 > PlgA.Rows.Count Then
MsgBox "Attention: il manque " & Ls - 1 - PlgA.Rows.Count & _
" ligne(s) pour calculer" & vbLf & "le récapitulatif dans '" & PlgA.Worksheet.Name & "'!" & PlgA.Address, _
vbExclamation, "Fonction Récap"
Récap = CVErr(xlErrRef): Exit Function
End If
While Ls <= UBound(TRés, 1)
TRés(Ls, 1) = CVErr(xlErrNA)
For P = 2 To UBound(TSrcS): TRés(Ls, P) = "": Next P
Ls = Ls + 1: Wend
Récap = TRés
Exit Function
Erreur: MsgBox Err.Description: Stop: Resume
End Function