Private Sub Worksheet_Calculate()
Dim PC As Range, pcr&, i&, h&
On Error Resume Next
Set PC = [PremiereCellule]: pcr = PC.Row
i = Application.Match(9 ^ 99, PC.EntireColumn): h = i - pcr - 1
'---correction si le tableau est trié sur une autre colonne que la 1ère colonne---
If Evaluate("SUM(-(" & PC(2).Resize(h).Address & "<" & PC(3).Resize(h).Address & "))") _
And Evaluate("SUM(-(" & PC(2).Resize(h).Address & ">" & PC(3).Resize(h).Address & "))") _
Or [U1].Offset(pcr, PC.Column - 1) = "" Then Worksheet_Change PC: Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NlignesVides&, PC As Range, pcr&, ColA As Range, i&, n&, MFC, zoneA&(), celBaseF1
Dim plageF1 As Range, plageF2 As Range, plageF3 As Range, pas%, a(), b(), plageMoy$, deb&, fin&, f$
NlignesVides = 10 'nombre de lignes vides sous le tableau, à adapter
Application.EnableEvents = False
On Error Resume Next
Set PC = [PremiereCellule]: pcr = PC.Row
'---interdit la suppression de "PremiereCellule" ou l'insertion de cellule/ligne sous les titres---
If pcr = 0 Or Rows(pcr + 1).SpecialCells(xlCellTypeAllFormatConditions).Count < 48 Then Application.Undo: GoTo 1 '48 à adapter
If Intersect(Target, [A:A,T:V,Y:AA,AD:AF,AI:AK,AN:AQ,AV:AV].Offset(, PC.Column - 1)) Is Nothing Then GoTo 1 'à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If ListObjects.Count Then ListObjects(1).TableStyle = "": ListObjects(1).Unlist 'si un tableau Excel a été créé
ShowAllData 'si la feuille est filtrée
'---détermination de ColA et épuration---
Set ColA = PC(2).Resize(Application.Match(9 ^ 99, PC.EntireColumn) - pcr)
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
If ColA.Count > 1 Then ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
If ColA.Count > 1 Then ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
'---mémorisation des lignes de début et de fin de zones en colonne A---
ReDim MFC(1 To pcr + ColA.Count, 1 To 1) 'tableau pour la MFC
For i = 1 To ColA.Count
If ColA(i) <> ColA(i - 1) Then
n = n + 1
ReDim Preserve zoneA(1 To 2, 1 To n)
zoneA(1, n) = i
End If
zoneA(2, n) = i
MFC(pcr + i, 1) = n Mod 2 'alternance
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Split([H1,J1,L1,N1,P1].Offset(pcr, PC.Column - 1).Address(0, 0), ",")
Set plageF1 = Intersect(ColA.EntireRow, [T:T].Offset(, PC.Column - 1))
Set plageF2 = Intersect(ColA.EntireRow, [U:U].Offset(, PC.Column - 1))
Set plageF3 = Intersect(ColA.EntireRow, [V:V].Offset(, PC.Column - 1))
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
Set plageF1 = plageF1.Offset(, pas * Sgn(i))
Set plageF2 = plageF2.Offset(, pas * Sgn(i))
Set plageF3 = plageF3.Offset(, pas * Sgn(i))
plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
For n = 1 To UBound(zoneA, 2)
deb = zoneA(1, n): fin = zoneA(2, n)
a(deb, 1) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
f = "=13*" & plageF2(deb).Address(1, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb)) _
& "/" & plageF1(deb).Address(0, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb))
For deb = deb To fin
b(deb, 1) = f
Next deb, n
plageF2 = a: plageF3 = b 'restitution
Next i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
'---MFC et formats---
i = 0: i = Application.Match(9 ^ 99, PC.EntireColumn) 'dernière ligne du tableau
If i <= pcr Then i = pcr + 1: Rows(i) = "" 'au moins une ligne pour conserver les formats
ThisWorkbook.Names.Add "MFC", MFC 'nom défini
Rows(pcr + 1).AutoFill Rows(pcr + 1 & ":" & i), xlFillFormats 'copie les formats
'---traitement des lignes sous le tableau---
Rows(i + 1).Resize([V:V].Offset(, PC.Column - 1).Find("=13*/*", , xlFormulas, xlWhole, , xlPrevious).Row - i).Delete 'RAZ
n = 0: n = Rows(i + 1 & ":" & Rows.Count).Find("*", Cells(Rows.Count, 1), xlValues, , xlByRows, xlNext).Row
If n Then n = i + NlignesVides + 1 - n 'écart
If n > 0 Then Rows(i + 1).Resize(n).Insert: Rows(Rows.Count).Copy Rows(i + 1).Resize(n)
If n < 0 Then Rows(i + 1).Resize(-n).Delete
Application.Calculation = xlCalculationAutomatic
1 Application.EnableEvents = True
With UsedRange: End With 'actualise les barres de défilement
'---en cas d'oubli---
pcr = [PremiereCellule].Row
If pcr = 0 Then MsgBox "Vous devez créer le nom ""PremiereCellule"" !", 48
End Sub
)
