calcul a chaque changement de nom

Private Sub Calcul()
Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Dim xdlgn As Long, i As Long, xlgnadresse As Long
Dim xtlop1 As Integer, xtlop2 As Integer, xtlop3 As Integer, xdetail As String, xnom As String
' Tri de la feuille2 sur la colonne C
xdlgn = Range("C" & Rows.Count).End(xlUp).Row
Range("A7:L" & xdlgn).Sort Key1:=Worksheets("Feuil2").Range("C7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Effacement des totaux
For i = 7 To xdlgn
If Cells(i, 3) <> i - 1 Then 'Rows(i).Delete

End If
Next i
' Ecriture de l'entête
xlgnadresse = 7: xnom = Cells(xlgnadresse, 3)
' Call EcritureEntete(xlgnadresse, xnom)
' boucle sur la feuille 2
i = 8
Do While Cells(i, 3) <> ""
If Cells(i, 3) = xnom Then
xtlop1 = xtlop1 + Cells(i, 6).Value: xtlop2 = xtlop2 + Cells(i, 7).Value: xtlop3 = xtlop3 + Cells(i, 8).Value: xdetail = xdetail + Cells(i, 9).Value & "/"
i = i + 1
Else
Call EcrituresTotaux(xtlop1, xtlop2, xtlop3, xdetail, xlgnadresse)
xtlop1 = 0: xtlop2 = 0: xtlop3 = 0: xdetail = " "
xnom = Cells(i, 3): xlgnadresse = i
' Ecriture de l'entête
' Call EcritureEntete(xlgnadresse, xnom)
i = i + 1
End If
Loop
Call EcrituresTotaux(xtlop1, xtlop2, xtlop3, xdetail, xlgnadresse)
' Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Cliquez pour agrandir...

jjjerome à dit:

Merci pour ta réponse, seul petit point de détail, je ne voudrais pas qu' un ajout de ligne soit fait, même lors de la première exécution de la macro, mes lignes entête sont toujours existante (il n'y a pas d'ajout de ligne une fois que la ligne entête à été crée 1 fois, ça c'est OK !!).

Cliquez pour agrandir...