additionner différentes cellules sur differentes feuillesà partir d'une liste non déterminée

=SIERREUR(EXP(LN(SIERREUR(--RECHERCHEV($B4;'recap S1'!$B:$AY;COLONNE()-1;0);0)+SIERREUR(--RECHERCHEV($B4;'recap S2'!$B:$AY;COLONNE()-1;0);0)+SIERREUR(--RECHERCHEV($B4;'recap S3'!$B:$AY;COLONNE()-1;0);0)+SIERREUR(--RECHERCHEV($B4;'recap S4'!$B:$AY;COLONNE()-1;0);0)+SIERREUR(--RECHERCHEV($B4;'recap S5'!$B:$AY;COLONNE()-1;0);0)+SIERREUR(--RECHERCHEV($B4;'recap S6'!$B:$AY;COLONNE()-1;0);0)));"")

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim P As Range, ncol%, x$, y$, d As Object, d1 As Object, i&, w As Worksheet, tablo, a, b, j%
Set P = Sh.[A2:AY143] 'à adapter
ncol = P.Columns.Count
x = "recap s" 'texte à adapter, en minuscules
y = "SEANCE "
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d1.CompareMode = vbTextCompare
Application.ScreenUpdating = False
If LCase(Sh.Name) Like x & "#*" Then
    P.Offset(2) = "" 'RAZ
    i = Val(Mid(Sh.Name, Len(x) + 1))
    On Error Resume Next
    Set w = Sheets(y & i)
    On Error GoTo 0
    If w Is Nothing Then Exit Sub
    tablo = w.[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
    For i = 2 To UBound(tablo)
        x = tablo(i, 2)
        If x <> "" And Not d.exists(x) Then d(x) = d.Count + 1
        y = x & Chr(1) & tablo(i, 3) & Chr(1) & tablo(i, 6)
        d1(y) = d1(y) + 1 'comptage
    Next i
    If d.Count = 0 Then Exit Sub
    '---restitution---
    a = d.keys: b = d.items
    tablo = P 'matrice, plus rapide
    For i = 3 To d.Count + 2
        x = a(i - 3)
        tablo(i, 1) = b(i - 3): tablo(i, 2) = x
        For j = 3 To ncol
            y = x & Chr(1) & tablo(1, j) & Chr(1) & tablo(2, j)
            If d1.exists(y) Then tablo(i, j) = d1(y)
    Next j, i
    P.Resize(d.Count + 2) = tablo
ElseIf LCase(Sh.Name) = "global seances" Then
    P.Offset(2) = "" 'RAZ
    For Each w In Worksheets
        If LCase(w.Name) Like x & "#*" Then
            Workbook_SheetActivate w 'lance la macro
            tablo = w.Range(P.Address) 'matrice, plus rapide
            For i = 3 To UBound(tablo)
                y = tablo(i, 2)
                If y <> "" And Not d.exists(y) Then d(y) = d.Count + 1
                For j = 3 To ncol
                    If tablo(i, j) <> "" Then d1(y & j) = d1(y & j) + tablo(i, j)
            Next j, i
        End If
    Next w
    If d.Count = 0 Then Exit Sub
    '---restitution---
    a = d.keys: b = d.items
    tablo = P 'matrice, plus rapide
    For i = 3 To d.Count + 2
        y = a(i - 3)
        tablo(i, 1) = b(i - 3): tablo(i, 2) = y
        For j = 3 To ncol
            tablo(i, j) = d1(y & j)
    Next j, i
    P.Resize(d.Count + 2) = tablo
End If
End Sub