Macro juste mais execution un peu longue......

[Evelynetfrancois]

bonjour à tous

j'utilise , grace a ce forum bien sur !!, cette macro ci dessous .
Elle fonctionne tres bien , et correspond parfaitement à mon attente
mais elle est particulierement longue à s 'executer.......................
voyez vous une correction à y apporter pour l'activer un peu ?
je vous remercie d avance pour le temps que vous pourriez me consacrer, et toutes vos aides si precieuses .
bonne journée à tous
E et F

_______________________________________________________
Private Sub OptionButton1_Click()
Dim cell As Range
Dim depart As String
Dim vide As Integer
Application.ScreenUpdating = False
Range("D2").Select
Selection.Interior.ColorIndex = 3
Range("E2").Select
Selection.Interior.ColorIndex = 47
Range("F2").Select
Selection.Interior.ColorIndex = 47
With Selection
.AutoFilter Field:=1
.AutoFilter Field:=2
.AutoFilter Field:=3
.AutoFilter Field:=4
.AutoFilter Field:=5
.AutoFilter Field:=6
End With
Range("A4:F600").Select
Selection.Sort Key1:=Range("F4"), Order1:=xlAscending, Key2:=Range("E4" _
), Order2:=xlAscending, Key3:=Range("B4"), Order3:=xlAscending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal


vide = 3
depart = Range("B3").Value
For Each cell In Range("a4", Range("A65536").End(xlUp).Offset(1, 0))
If Rows(cell.Row).Hidden = False Then
If Not cell.Value = depart Then
Rows(cell.Row).Insert Shift:=xlDown
If cell.Row > 5 Then
Range("D" & cell.Row - 1).Formula = "=SUM(D" & vide & "😀" & cell.Row - 2 & ")"
Range("D" & cell.Row - 1).Interior.ColorIndex = 6
End If
vide = cell.Row
depart = cell.Value
End If
End If
Next
Application.ScreenUpdating = True
Range("A4").Select
Unload Me
End Sub

 

[JeanMarie]

Re : Macro juste mais execution un peu longue......

Bonjour

Fait un essai avec ce code

[COLOR=Blue]Private Sub OptionButton1_Click()
Dim cell As Range
Dim depart As String
Dim vide As Integer
Dim vRowA as Integer
Dim vRowB as Integer
Application.ScreenUpdating = False
[COLOR=Red]Application.Calculation = xlManual[/COLOR][COLOR=SeaGreen]
Range("D2").Interior.ColorIndex = 3
Range("E2:F2").Interior.ColorIndex = 47[/COLOR]
 With Selection
.AutoFilter Field:=1
.AutoFilter Field:=2
.AutoFilter Field:=3
.AutoFilter Field:=4
.AutoFilter Field:=5
.AutoFilter Field:=6
End With
Range("A4:F600").Sort Key1:=Range("F4"), Order1:=xlAscending, Key2:=Range("E4" _
        ), Order2:=xlAscending, Key3:=Range("B4"), Order3:=xlAscending, Header _
        :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
        , DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal


vide = 3
depart = Range("B3").Value
For Each cell In Range("a4", Range("A65536").End(xlUp).Offset(1, 0))
[COLOR=Red]vRowA = [/COLOR][/COLOR][COLOR=Red]cell.Row[/COLOR]
[COLOR=Blue] If Rows([COLOR=Red]vRowA[/COLOR]).Hidden = False Then
If Not cell.Value = depart Then
Rows([/COLOR][COLOR=Blue][COLOR=Red]vRowA[/COLOR][/COLOR][COLOR=Blue]).Insert Shift:=xlDown
If cell.Row > 5 Then
[/COLOR][COLOR=Red]vRowB =[/COLOR][COLOR=Red]cell.RowB - 1[/COLOR]
[COLOR=Blue] Range("D" & [COLOR=Red]vRowB[/COLOR]).Formula = "=SUM(D" & vide & ":D" & [/COLOR][COLOR=Blue][COLOR=Red]vRowA[/COLOR][/COLOR][COLOR=Blue] - 2 & ")"
Range("D" & [COLOR=Red]vRowB[/COLOR]).Interior.ColorIndex = 6
End If
vide = cell.Row
depart = cell.Value
End If
End If
Next
[/COLOR][COLOR=Blue][COLOR=Red]Application.Calculation = xlAutomatic
Application.Calculate
[/COLOR][/COLOR][COLOR=Blue] Application.ScreenUpdating = True
Range("A4").Select
Unload Me
End Sub[/COLOR]

@+Jean-Marie

 

[Evelynetfrancois]

Re : Macro juste mais execution un peu longue......

bonjour jean marie
je te remercie pour ton aide
j ai essaye ta macro apres avoir corrige une toute petite erreur de saisie
vRowB = cell.RowB - 1 en vRowB = cell.Row - 1
la macro s execute bien plus vite , mais les sous totaux sont fantaisistes !!!

vois tu la raison ?

bonne soirée a toi au plaisir de te lire

E et F

 

[Evelynetfrancois]

Re : Macro juste mais execution un peu longue......

bonjour
voila comme ça tout rentre dans l ordre
bon aprem..........
E et F

Private Sub OptionButton1_Click()
Dim cell As Range
Dim depart As String
Dim vide As Integer
Dim vRowA As Integer
Dim vRowB As Integer
Application.ScreenUpdating = False
Application.Calculation = xlManual
Range("D2").Interior.ColorIndex = 3
Range("E2:F2").Interior.ColorIndex = 47
With Selection
.AutoFilter Field:=1
.AutoFilter Field:=2
.AutoFilter Field:=3
.AutoFilter Field:=4
.AutoFilter Field:=5
.AutoFilter Field:=6
End With
Range("A4:F600").Sort Key1:=Range("F4"), Order1:=xlAscending, Key2:=Range("E4" _
), Order2:=xlAscending, Key3:=Range("B4"), Order3:=xlAscending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
vide = 3
depart = Range("B3").Value
For Each cell In Range("a4", Range("A65536").End(xlUp).Offset(1, 0))
If Rows(cell.Row).Hidden = False Then
If Not cell.Value = depart Then
Rows(cell.Row).Insert Shift:=xlDown
If cell.Row > 5 Then
vRowA = cell.Row - 2
vRowB = cell.Row - 1
Range("D" & vRowB).Formula = "=SUM(D" & vide & "😀" & vRowA & ")"
Range("D" & vRowB).Interior.ColorIndex = 6
End If
vide = cell.Row
depart = cell.Value
End If
End If
Next
Application.Calculation = xlAutomatic
Application.Calculate
Application.ScreenUpdating = True
Range("A4").Select
Unload Me
End Sub

 

[wilfried_42]

Re : Macro juste mais execution un peu longue......

bonjour à tous

les sous totaux sont fantaisistes depuis que tu as empeché les calculs automatiques.
c'est donc que ta macro met a jour des cellules qui provoquent des calculs dont le resultat est reutlisé pas cette meme macro

il va falloir enlever Application.calculate = xlmanual

 

[Evelynetfrancois]

Re : Macro juste mais execution un peu longue......

bonsoir wilfried_42
pour info
la macro fonctionne bien maintenant .j ai juste remis un peu d ordre dans les lignes et le calcul est juste , par contre
si je laisse le calcul auto , la macro mets presque 1 minute a s effectuer contre 1,5 seconde en Application.Calculation = xlManual

bonne soirée a tous
E et F