Sub ExtraireCoef_Separation()
Dim ws As Worksheet, vs As Worksheet
Dim LastRowBute As Long, ligneCible As Long
Dim valeurRecherchee As Variant
Dim j As Long, i As Long, l As Long, z As Long, y As Long
Dim xVals() As Double, yVals() As Double
Dim coeffs As Variant
Dim evt As Variant
Dim validCount As Long
Dim startRow As Long, endRow As Long
Dim lastEvt As Long
' --- Feuilles ---
Set ws = ThisWorkbook.Sheets("S80H9 F3")
Set vs = ThisWorkbook.Sheets("Graph S80H9 F3 Vieillissement")
'Clear tableau
vs.Range(vs.Cells(45, 4), vs.Cells(364, 8)).ClearContents
' --- Détermination du LastRow pour les butées ---
LastRowBute = 0
For j = 3 To 34
If Trim(vs.Cells(j, 15).Value) = "" Then
LastRowBute = j - 1
Exit For
End If
Next j
If LastRowBute = 0 Then LastRowBute = 34
Debug.Print " LastRowBute :" & LastRowBute
' --- Boucle sur chaque butée ---
For Each Cell In vs.Range(vs.Cells(3, 15), vs.Cells(LastRowBute, 15))
valeurRecherchee = Trim(Cell.Value)
Debug.Print "valeurRecherchee :" & valeurRecherchee
' --- Ligne de départ dans le tableau de coef ---
ligneCible = 0
For j = 45 To 364
If CStr(Trim(vs.Cells(j, 2).MergeArea.Cells(1, 1).Value)) = CStr(valeurRecherchee) Then
ligneCible = j
Exit For
End If
Next j
If ligneCible = 0 Then GoTo NextButée
Debug.Print " ligneCible : " & ligneCible
startRow = 0
endRow = 0
' --- Trouver les lignes correspondant à la butée dans la colonne A fusionnée ---
For l = 4 To 59931
If CStr(Trim(ws.Cells(l, 1).MergeArea.Cells(1, 1).Value)) = CStr(valeurRecherchee) Then
If startRow = 0 Then startRow = l
endRow = l
End If
Next l
Debug.Print "startRow :" & startRow
Debug.Print " endRow :" & endRow
If startRow = 0 Then
Debug.Print "Aucune donnée pour la butée " & valeurRecherchee
GoTo NextButée
End If
' --- Compter les événements valides ---
' Ancien, avec les cellules fusionnées ne marchent plus correctement
' lastEvt = 0
' Dim cellEvt As Range
' For j = 45 To 64
' Set cellEvt = vs.Cells(j, 3)
' ' On ne compte qu'une seule fois par bloc fusionné
' If cellEvt.MergeArea.Cells(1, 1).Row = cellEvt.Row Then
' If cellEvt.Value <> 0 And cellEvt.Value <> "" Then
' lastEvt = lastEvt + 1
' End If
' End If
' Next j
' --- Identifier les lignes d’EVENT (fusionnées sur 2 lignes) ---
Dim EventRows() As Long
Dim cellEvt As Range
lastEvt = 0
For j = 45 To 64
Set cellEvt = vs.Cells(j, 3)
' Si c’est la première ligne d’un bloc fusionné et qu’il contient un EVENT
If cellEvt.MergeArea.Cells(1, 1).Row = cellEvt.Row Then
If Trim(cellEvt.Value) <> "" And cellEvt.Value <> 0 Then
lastEvt = lastEvt + 1
ReDim Preserve EventRows(1 To lastEvt)
EventRows(lastEvt) = j ' On retient la 1ère ligne fusionnée
End If
End If
Next j
Debug.Print "NombreEvent détectés : " & lastEvt
' --- Boucle sur chaque EVENT ---
For j = 1 To lastEvt
evt = vs.Cells(EventRows(j), 3).Value
Debug.Print "Event actuel :" & evt
ws.Range("BG3").Value = evt
' --- Préparer les tableaux X et Y ---
validCount = 0
ReDim xVals(1 To endRow - startRow + 1)
ReDim yVals(1 To endRow - startRow + 1)
For z = startRow To endRow
If IsNumeric(ws.Cells(z, 60).Value) And ws.Cells(z, 60).Value <> 0 And _
IsNumeric(ws.Cells(z, 59).Value) And ws.Cells(z, 59).Value <> 0 Then
validCount = validCount + 1
xVals(validCount) = ws.Cells(z, 60).Value ' BH
yVals(validCount) = ws.Cells(z, 59).Value ' BG
End If
Next z
If validCount = 0 Then GoTo NextEVENT
ReDim Preserve xVals(1 To validCount)
ReDim Preserve yVals(1 To validCount)
' --- DÉTECTION DU MAX DE LA COURBE ---
Dim idxMax As Long, yMax As Double
yMax = -1E+99
For i = 1 To validCount
If yVals(i) > yMax Then
yMax = yVals(i)
idxMax = i
End If
Next i
Debug.Print " -> yMax=" & yMax & " à index " & idxMax
' === PARTIE 1 (avant le max) ===
Call DoLinEst(ws, vs, xVals, yVals, 1, idxMax, EventRows(j) + ligneCible - 45, CStr(valeurRecherchee), "Partie 1")
' === PARTIE 2 (après le max) ===
If idxMax < validCount Then
Call DoLinEst(ws, vs, xVals, yVals, idxMax, validCount, EventRows(j) + 1 + ligneCible - 45, CStr(valeurRecherchee), "Partie 2")
End If
vs.Cells(EventRows(j) + ligneCible - 45, 8).Value = yMax
NextEVENT:
Next j
NextButée:
Next Cell
MsgBox "Extraction coefficients terminée."
End Sub
' --- Sous-fonction : fait le LINEST sur une plage donnée et écrit les coefficients ---
Private Sub DoLinEst(ws As Worksheet, vs As Worksheet, xVals() As Double, yVals() As Double, _
startIdx As Long, endIdx As Long, ligneOut As Long, butee As String, label As String)
Dim n As Long
n = endIdx - startIdx + 1
If n < 5 Then
Debug.Print " [" & label & "] Pas assez de points pour " & butee
Exit Sub
End If
Dim tmpX() As Double, tmpY() As Double
ReDim tmpX(1 To n)
ReDim tmpY(1 To n)
Dim i As Long
For i = 1 To n
tmpX(i) = xVals(startIdx + i - 1)
tmpY(i) = yVals(startIdx + i - 1)
Next i
ws.Range("ZZ1:AAA10000").ClearContents
ws.Range("ZZ1").Resize(n, 1).Value = Application.Transpose(tmpY)
ws.Range("AAA1").Resize(n, 1).Value = Application.Transpose(tmpX)
Dim yRangeStr As String, xRangeStr As String, formulaStr As String
yRangeStr = "'" & ws.Name & "'!$ZZ$1:$ZZ$" & n
xRangeStr = "'" & ws.Name & "'!$AAA$1:$AAA$" & n
formulaStr = "LINEST(" & yRangeStr & ",POWER(" & xRangeStr & ",{1,2,3}),TRUE,FALSE)"
Dim coeffs As Variant
' coeffs = Evaluate(formulaStr)
'
' If IsArray(coeffs) Then
' For i = LBound(coeffs, 2) To UBound(coeffs, 2)
' vs.Cells(ligneOut, 3 + i).Value = coeffs(1, i)
' Next i
' Debug.Print " [" & label & "] OK (" & n & " points) -> ligne " & ligneOut
' Else
' Debug.Print " [" & label & "] LINEST vide"
' End If
'Test
coeffs = Evaluate(formulaStr)
Dim compteur As Long
compteur = 0
If Not IsEmpty(coeffs) Then
If IsArray(coeffs) Then
Dim r As Long, c As Long
On Error Resume Next
' Essai dimension 2
For r = LBound(coeffs, 1) To UBound(coeffs, 1)
For c = LBound(coeffs, 2) To UBound(coeffs, 2)
Debug.Print "coeffs(" & r & "," & c & ") = " & coeffs(r, c)
Next c
Next r
If Err.Number <> 0 Then
Err.Clear
' Cas tableau 1D
For r = LBound(coeffs) To UBound(coeffs)
Debug.Print "coeffs(" & r & ") = " & coeffs(r)
vs.Cells(ligneOut, 4 + compteur).Value = coeffs(r)
debut.Print " ligneOut :" & ligneOut
compteur = compteur + 1
Next r
End If
On Error GoTo 0
Else
Debug.Print "coeffs n'est pas un tableau : " & coeffs
End If
Else
Debug.Print "coeffs est vide"
End If
End Sub