Problème de rapidité

Signaler
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
-
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
-
Bonjour,

Après avoir créé un Macro VBA sur Excel, la première fois que je l'exécute, tout se passe très rapidement. Mais si j'exécute le macro une deuxième fois, cela prend un temps fou! Par contre si je quitte le fichier, et je le reouvre, tout se passe normalement...

J'imagine que la mémoire est pleine à quelque part, mais où? Et comment la vider? Et cela ne provient pas du presse papier qui est vide!

Merci de votre aide!

13 réponses

Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
18
Salut,

J'ai déjà remarqué le phénomène et je n'ai pas de réponse ...
Mais peut-être que si tu mettais un bout de ton code, on pourrait aider à l'améliorer, le cas échéant...

MPi²
Pour ceux qui programment sous Office, n'oubliez pas qu'il existe un forum dédié à ces applications VBA.
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009

Mon code est assez long, et je ne crois pas que le problème viennent de là mais plutot qu'excel à du mal à appliquer un format après que la macro l'ait déjà fait une fois!

Ne vois tu rien qui pourrait vider la mémoire?
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
26
Essaye d'enregistrer ton classeur entre 2 exécutions de cette macro...
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009

J'avais déjà essayé mais cela ne change rien! Auriez-vous d'autres solutions?

Merci d'avance
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
26
 "Auriez-vous d'autres solutions?"


Non ... sans avoir une parfaite connaissance de tous les tenants et aboutissants de ton application... et notamment de ce qu'elle crée ici et là et ne tue pas ...

J'espérais que le problème avait pour cause la conservation en mémoire de données pour permettre des "retours en arrière", problème qui aurait été résolu par l'enregistrement de ton classeur... mais tu nous dis que tu as déjà essayé cette méthode sans succès, alors.... ===>> le problème est ailleurs et on ne peut le savoir sans voir la totalité de ton code !
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
41
salut,
ce lien peut te montrer comment décharger des objets si le problème vient de là, ce qu'on ne peut que lire, pas deviner
++
<hr size="2" width="100%" />Prenez un instant pour répondre à [infomsg_SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009

Sub Macro1()

'Unprotects Présentation

Worksheets("Présentation").Unprotect Password:="AAA"

'Errors msg (Month & Type)

If Worksheets("Données").Cells(72, 2).Value = "OK" Then

Else

MsgBox "Veuillez contrôler qu'à toutes les opérations, le type à été spécifié"

Exit Sub

End If

If Worksheets("Données").Cells(4, 5).Value <> "Mois" Then

Else

MsgBox "Veuillez spécifier un mois"

Exit Sub

End If

If Worksheets("Données").Cells(4, 5).Value <> "" Then

Else

MsgBox "Veuillez spécifier un mois"

Exit Sub

End If


'Delete the old preview

Worksheets("Présentation").Select
Cells.Select
Selection.Delete Shift:=xlUp
Cells.ClearContents
Cells.Clear

'Formats Présentation Background, Columns & Header

Worksheets("Présentation").Select
Cells.Select

With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With

Worksheets("Présentation").Range("A:A").Select
Selection.ColumnWidth = 2
Worksheets("Présentation").Range("B:B,C:C").Select
Selection.ColumnWidth = 1
Columns("D:D").Select
Selection.ColumnWidth = 25
Range("E:E,G:G,I:I").Select
Selection.ColumnWidth = 15
Range("F:F,H:H").Select
Selection.ColumnWidth = 3
Range("J:J").Select
Selection.ColumnWidth = 2

Range("A1:J2").Select
With Selection.Interior
.ColorIndex = 55
.Pattern = xlSolid
End With

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Selection.Merge
Range("A1:J2").Select

Selection.RowHeight = 17

Worksheets("Présentation").Cells(1, 1).Value = "Dépenses et Revenus - " & Worksheets("Données").Cells(4, 5).Value & " " & Worksheets("Données").Cells(2, 5).Value

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

With Selection.Font
.Name = "Arial"
.Size = 13
.Bold = True
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2

End With

Worksheets("Présentation").Cells(4, 5).Value = Worksheets("Données").Cells(4, 5).Value

Worksheets("Présentation").Cells(4, 7).Value = "Total " & Worksheets("Données").Cells(2, 5).Value

Worksheets("Présentation").Cells(4, 9).Value = "Moyenne " & Worksheets("Données").Cells(2, 5).Value

Union(Worksheets("Présentation").Cells(4, 5), Worksheets("Présentation").Cells(4, 7), Worksheets("Présentation").Cells(4, 9)).Select

Selection.RowHeight = 30
Selection.Font.Bold = True

With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


'Puts table into the matrix

For I = 9 To 70
If Worksheets("Données").Cells(I, 5).Value = "" Then
num = I - 1
I = 70
End If
Next I

ReDim mat(num - 8, 3), mat1(num - 8, 3), mat2(num - 8, 3)

For I = 3 To 5
For J = 9 To num
mat(J - 8, I - 2) = Worksheets("Données").Cells(J, I).Value
Next J
Next I

'Removes None Objects

For I = 1 To 3
For J = 9 To num

If mat(J - 8, I) = "NONE" Then
mat(J - 8, I) = ""
End If

If mat(J - 8, I) = "None" Then
mat(J - 8, I) = ""
End If

Next J
Next I


'Puts the matrix in order

k = 0
For I = 1 To num - 8
If I > num - 8 Then
Exit For
ElseIf mat(I, 1) <> "" Then
k = k + 1
mat1(k, 1) = mat(I, 1)
mat1(k, 2) = mat(I, 2)
mat1(k, 3) = mat(I, 3)
mat(I, 1) = ""
mat(I, 2) = ""
mat(I, 3) = ""
For J = I + 1 To num - 8
If J > num - 8 Then
Exit For
ElseIf mat(J, 1) = mat1(k, 1) And mat(J, 1) <> "" Then
k = k + 1
mat1(k, 1) = mat(J, 1)
mat1(k, 2) = mat(J, 2)
mat1(k, 3) = mat(J, 3)
mat(J, 1) = ""
mat(J, 2) = ""
mat(J, 3) = ""
End If
Next J
End If
Next I

k = 0
For I = 1 To num - 8
If I > num - 8 Then
Exit For
ElseIf mat1(I, 1) <> "" Then
k = k + 1
mat2(k, 1) = mat1(I, 1)
mat2(k, 2) = mat1(I, 2)
mat2(k, 3) = mat1(I, 3)
mat1(I, 1) = ""
mat1(I, 2) = ""
mat1(I, 3) = ""
For J = I + 1 To num - 8
If J > num - 8 Then
Exit For
ElseIf mat1(J, 1) mat2(k, 1) And mat1(J, 2) mat2(k, 2) Then
k = k + 1
mat2(k, 1) = mat1(J, 1)
mat2(k, 2) = mat1(J, 2)
mat2(k, 3) = mat1(J, 3)
mat1(J, 1) = ""
mat1(J, 2) = ""
mat1(J, 3) = ""
End If
Next J
End If
Next I


'Removes repeted names

For I = num - 8 To 1 Step -1
If mat2(I, 1) mat2(I, 2) mat2(I, 3) <> "" Then
For J = I - 1 To 1 Step -1
If mat2(I, 1) mat2(J, 1) And mat2(I, 2) mat2(J, 2) And mat2(I, 3) = mat2(J, 3) Then
mat2(J, 1) = ""
mat2(J, 2) = ""
mat2(J, 3) = ""
End If
Next J
End If
Next I

For I = num - 8 To 1 Step -1
If mat2(I, 1) = mat2(I, 2) <> "" Then
For J = I - 1 To 1 Step -1
If mat2(I, 1) mat2(J, 1) And mat2(I, 2) mat2(J, 2) Then
mat2(J, 1) = ""
mat2(J, 2) = ""
End If
Next J
End If
Next I

For I = num - 8 To 1 Step -1
If mat2(I, 1) <> "" Then
For J = I - 1 To 1 Step -1
If mat2(I, 1) = mat2(J, 1) Then
mat2(J, 1) = ""
End If
Next J
End If
Next I


'Counts number of rows with something

k = 0
For I = 1 To num - 8
If mat2(I, 3) <> "" Then
k = k + 1
End If
Next I

ReDim mat3(k, 3)


'Removes gaps

k = 0
For I = 1 To num - 8
If mat2(I, 3) <> "" Then
k = k + 1
mat3(k, 1) = mat2(I, 1)
mat3(k, 2) = mat2(I, 2)
mat3(k, 3) = mat2(I, 3)
End If
Next I


'Invert the columns

ReDim mat4(k, 3)
For I = 1 To 3
For J = 1 To k
mat4(J, I) = mat3(J, 4 - I)
Next J
Next I


'Puts matrix onto Présentation

For I = 1 To k
For J = 1 To 3

Worksheets("Présentation").Cells(4 + I, J + 1).Value = mat4(I, J)

Next J
Next I

'Counts number of row with spaces

Q = 0

For I = 1 To k
For J = 1 To 3

If mat4(I, J) <> "" Then

Q = Q + 1

End If

Next J

If mat4(I, 3) <> "" Then

Q = Q + 1

End If

Next I

Q = Q - 1 ' Deletes added row below the last cat1


'Moves names to correct place

For I = 1 To Q

If Worksheets("Présentation").Cells(4 + I, 3).Value <> "" Then

Worksheets("Présentation").Cells(4 + I + 1, 3).Select

Selection.EntireRow.Insert

End If

If Worksheets("Présentation").Cells(4 + I, 4).Value <> "" Then

Worksheets("Présentation").Cells(4 + I + 1, 4).Select

Selection.EntireRow.Insert
Selection.EntireRow.Insert

End If
Next I

Worksheets("Présentation").Cells(5, 3).Select
Selection.Insert Shift:=xlDown

Worksheets("Présentation").Cells(5, 4).Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown

'Formats variable part

For I = 1 To Q + 4
For J = 1 To 10

If Worksheets("Présentation").Cells(I, 3) <> "" Then

Worksheets("Présentation").Cells(I, J).Select

Selection.RowHeight = 24.5
Selection.Font.Bold = True
Selection.Font.Italic = True

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

End If

If Worksheets("Présentation").Cells(I, 4) <> "" Then

Worksheets("Présentation").Range("Présentation!A" & I & ":J" & I & "").Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Selection.Borders(xlInsideVertical).LineStyle = xlNone

With Selection.Interior
.ColorIndex = 47
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With

End If



Next J
Next I

For I = 1 To Q + 12
For J = 5 To 10

Worksheets("Présentation").Cells(I + 4, J).Select
Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"

Next J
Next I


'Formats Présentation Footer

Worksheets("Présentation").Cells(Q + 6, 4).Value = "Variation de trésorerie"

Worksheets("Présentation").Range("Présentation!A" & Q + 6 & ":J" & Q + 6 & "").Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Selection.Borders(xlInsideVertical).LineStyle = xlNone

With Selection.Interior
.ColorIndex = 55
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With

Worksheets("Présentation").Cells(Q + 8, 2).Value = Worksheets("Données").Cells(3, 2)
Worksheets("Présentation").Cells(Q + 9, 2).Value = Worksheets("Données").Cells(4, 2)
Worksheets("Présentation").Cells(Q + 10, 2).Value = Worksheets("Données").Cells(5, 2)

Worksheets("Présentation").Cells(Q + 12, 4).Value = "Liquidités"

Worksheets("Présentation").Range("Présentation!A" & Q + 12 & ":J" & Q + 12 & "").Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Selection.Borders(xlInsideVertical).LineStyle = xlNone

With Selection.Interior
.ColorIndex = 55
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With


'Variable part formulas

Dim Value

Value = Worksheets("Données").Cells(4, 5).Value

Select Case Value

Case "Janvier"
k = "I"
Case "Février"
k = "L"
Case "Mars"
k = "O"
Case "Avril"
k = "R"
Case "Mai"
k = "U"
Case "Juin"
k = "X"
Case "Juillet"
k = "AA"
Case "Août"
k = "AD"
Case "Septembre"
k = "AG"
Case "Octobre"
k = "AJ"
Case "Novembre"
k = "AM"
Case "Décembre"
k = "AP"

End Select

For I = 1 To Q


'Defines where cat1 & cat 2 stops

EndCat2 = Cells(I + 4, 3).End(xlDown).Row

EndCat1 = Cells(I + 4, 4).End(xlDown).Row


'By Month

If Worksheets("Présentation").Cells(I + 4, 2).Value <> "" Then

Cells(I + 4, 5).FormulaArray = "=SUM(IF(B" & I + 4 & " =Données!$E$9:$E$70,IF(C" & EndCat2 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!" & k & "9:" & k & "70),0),0),0))" 'Sum Cat3

End If

If Worksheets("Présentation").Cells(I + 4, 3).Value <> "" Then

Cells(I + 4, 5).FormulaArray = "=SUM(IF(C" & I + 4 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!" & k & "9:" & k & "70),0),0))" 'Sum Cat2

End If

If Worksheets("Présentation").Cells(I + 4, 4).Value <> "" Then

Cells(I + 4, 5).Formula = "=SUMIF(Données!C9:C70, D" & I + 4 & " ,Données!" & k & "9:" & k & "70)" 'Sum Cat1

End If


'By Year

If Worksheets("Présentation").Cells(I + 4, 2).Value <> "" Then

Cells(I + 4, 7).FormulaArray = "=SUM(IF(B" & I + 4 & " =Données!$E$9:$E$70,IF(C" & EndCat2 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!AS9:AS70),0),0),0))" 'Sum Cat3

End If

If Worksheets("Présentation").Cells(I + 4, 3).Value <> "" Then

Cells(I + 4, 7).FormulaArray = "=SUM(IF(C" & I + 4 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!AS9:AS70),0),0))" 'Sum Cat2

End If

If Worksheets("Présentation").Cells(I + 4, 4).Value <> "" Then

Cells(I + 4, 7).Formula = "=SUMIF(Données!C9:C70, D" & I + 4 & " ,Données!AS9:AS70)" 'Sum Cat1

End If


'In Average

If Worksheets("Présentation").Cells(I + 4, 2).Value <> "" Then

Cells(I + 4, 9).FormulaArray = "=SUM(IF(B" & I + 4 & " =Données!$E$9:$E$70,IF(C" & EndCat2 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!AV9:AV70),0),0),0))" 'Sum Cat3

End If

If Worksheets("Présentation").Cells(I + 4, 3).Value <> "" Then

Cells(I + 4, 9).FormulaArray = "=SUM(IF(C" & I + 4 & " =Données!$D$9:$D$70,IF(D" & EndCat1 & " =Données!$C$9:$C$70,1*(Données!AV9:AV70),0),0))" 'Sum Cat2

End If

If Worksheets("Présentation").Cells(I + 4, 4).Value <> "" Then

Cells(I + 4, 9).Formula = "=SUMIF(Données!C9:C70, D" & I + 4 & " ,Données!AV9:AV70)" 'Sum Cat1

End If

Next I



'Footer Formulas

Worksheets("Présentation").Cells(Q + 6, 5).Formula = "=SUMIF(D4:D" & Q + 4 & ",""<>"" & """",E4:E" & Q + 4 & ")" 'Variation de trésorerie
Worksheets("Présentation").Cells(Q + 6, 7).Formula = "=SUMIF(D4:D" & Q + 4 & ",""<>"" & """",G4:G" & Q + 4 & ")" 'Variation de trésorerie
Worksheets("Présentation").Cells(Q + 6, 9).Formula = "=SUMIF(D4:D" & Q + 4 & ",""<>"" & """",I4:I" & Q + 4 & ")" 'Variation de trésorerie

Worksheets("Présentation").Cells(Q + 8, 5).Formula = "=Données!" & k & "3" 'Solde compte bancaire
Worksheets("Présentation").Cells(Q + 9, 5).Formula = "=Données!" & k & "4" 'Solde compte bancaire
Worksheets("Présentation").Cells(Q + 10, 5).Formula = "=Données!" & k & "5" 'Solde compte bancaire

Worksheets("Présentation").Cells(Q + 12, 5).Formula = "=sum(E" & Q + 8 & ":E" & Q + 10 & ")" 'Somme de la trésorerie


'Defines the Print Area


Worksheets("Présentation").PageSetup.PrintArea = "A1:J" & Q + 12 & ""


'Protects Présentation

Worksheets("Présentation").Protect Password:="AAA"


End Sub



MERCI DE VOTRE AIDE
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
41
salut,

rien de déclaré, des tableaux qui sortent d'on ne sait où, des tests inutiles, c'est incompréhensible, pauvre excel ^^

voici le début..... mais j'ai perdu patience

Sub Macro1()

'Unprotects
Présentation

    Worksheets("Présentation").Unprotect Password:="AAA"

'Errors msg (Month &
Type)
    
    If Worksheets("Données").Cells(72, 2).Value = "OK" Then
    
        Else
      
        MsgBox "Veuillez contrôler qu'à toutes
les opérations, le type à été spécifié"
        
        Exit Sub
        
    End If
    
    
    
'''    If Worksheets("Données").Cells(4, 5).Value <> "Mois"
Then
'''
'''        Else
'''
'''        MsgBox "Veuillez spécifier un mois"
'''
'''        Exit
Sub
'''
'''    End
If
'''
'''     If
Worksheets("Données").Cells(4, 5).Value <> "" Then
'''
'''        Else
'''
'''        MsgBox "Veuillez
spécifier un mois"
'''
'''        Exit Sub
'''
'''    End
If

     If (Worksheets("Données").Cells(4, 5).Value = "Mois") Or (LenB(Worksheets("Données").Cells(4, 5).Value) = 0) Then

        MsgBox "Veuillez spécifier un
mois"
        
        Exit Sub

    End If
    
    
    
    
    
'Delete the old preview

    Worksheets("Présentation").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Cells.ClearContents
    Cells.Clear
    
'Formats
Présentation Background, Columns & Header

    Worksheets("Présentation").Select
    Cells.Select
    
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    
    Worksheets("Présentation").Range("A:A").Select
    Selection.ColumnWidth = 2
    Worksheets("Présentation").Range("B:B,C:C").Select
    Selection.ColumnWidth = 1
    Columns("D:D").Select
    Selection.ColumnWidth = 25
    Range("E:E,G:G,I:I").Select
    Selection.ColumnWidth = 15
    Range("F:F,H:H").Select
    Selection.ColumnWidth = 3
    Range("J:J").Select
    Selection.ColumnWidth = 2
    
    Range("A1:J2").Select
    With Selection.Interior
        .ColorIndex = 55
        .Pattern = xlSolid
    End With
    
    Selection.Borders(xlDiagonalDown).LineStyle =
xlNone
    Selection.Borders(xlDiagonalUp).LineStyle =
xlNone
    
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    Selection.Borders(xlInsideVertical).LineStyle =
xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle =
xlNone
    
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Selection.Merge
    Range("A1:J2").Select
    
    Selection.RowHeight = 17
    
    Worksheets("Présentation").Cells(1, 1).Value = "Dépenses et
Revenus  -  " & Worksheets("Données").Cells(4, 5).Value & " " & Worksheets("Données").Cells(2, 5).Value
    
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 1
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    
    With Selection.Font
        .Name = "Arial"
        .Size = 13
        .Bold = True
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
        
    End With
    
'''    Worksheets("Présentation").Cells(4, 5).Value =
Worksheets("Données").Cells(4, 5).Value
'''
'''    Worksheets("Présentation").Cells(4, 7).Value = "Total "
& Worksheets("Données").Cells(2, 5).Value
'''
'''    Worksheets("Présentation").Cells(4, 9).Value = "Moyenne "
& Worksheets("Données").Cells(2, 5).Value
'''
'''    Union(Worksheets("Présentation").Cells(4, 5),
Worksheets("Présentation").Cells(4, 7), Worksheets("Présentation").Cells(4,
9)).Select
 
 
    With Worksheets("Présentation")
        .Cells(4, 5).Value = Worksheets("Données").Cells(4, 5).Value
        
        .Cells(4, 7).Value = "Total " & Worksheets("Données").Cells(2, 5).Value
        
        .Cells(4, 9).Value = "Moyenne " & Worksheets("Données").Cells(2, 5).Value
        
        Union(.Cells(4, 5), .Cells(4, 7),
.Cells(4, 9)).Select
    End With
 
 
 
 
    Selection.RowHeight = 30
    Selection.Font.Bold = True
    
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    
'Puts table
into the matrix

'''For I = 9 To
70
'''    If Worksheets("Données").Cells(I,
5).Value = "" Then
'''        num = I -
1
'''        I = 70
'''    End If
'''Next
I

'!!!!!!!!!!!!
'   'NUM' ET 'I' NE SONT PAS DéCLARéS?!!!
'!!!!!!!!!!!!

Dim num As Integer
Dim I As Integer
For I = 9 To 70
    If LenB(Worksheets("Données").Cells(I, 5).Value) = 0 Then
        num = I - 1
        Exit For
    End If
Next I

'!!!!!!!!!!!!
'   ET 'MAT' N'EST PAS
DéCLARé NON PLUS?!!!
'!!!!!!!!!!!!
ReDim mat(num - 8, 3), mat1(num - 8, 3), mat2(num - 8, 3)

'!!!!!!!!!!!!
'   PAREIL POUR
'J'?!!!
'!!!!!!!!!!!!

Dim J As Integer
For I = 3 To 5
    For J = 9 To num
        mat(J - 8, I - 2) = Worksheets("Données").Cells(J, I).Value
    Next J
Next I

'Removes None Objects

For I = 1 To 3
'''    For J = 9 To
num
'''
'''        If mat(J - 8, I) = "NONE" Then
'''        mat(J - 8, I) = ""
'''        End If
'''
'''        If mat(J - 8, I) =
"None" Then
'''        mat(J - 8, I) =
""
'''        End If
'''
'''    Next
J

    For J = 9 To num
    
        If LCase$(mat(J - 8, I)) = "none" Then mat(J - 8, I) = ""
    
    Next J
Next I
    
    
'Puts the matrix
in order

'!!!!!!!!!!!!
'   PAREIL POUR 'k'?!!!
'!!!!!!!!!!!!
Dim k As Integer
k = 0
'''For I = 1 To num - 8
'''    If I
> num - 8 Then
'''        Exit
For
'''    ElseIf mat(I, 1) <> ""
Then
'''    k = k + 1
'''        mat1(k, 1) = mat(I, 1)
'''        mat1(k, 2) = mat(I, 2)
'''        mat1(k, 3) = mat(I, 3)
'''        mat(I, 1) = ""
'''        mat(I, 2) = ""
'''        mat(I, 3) = ""
'''        For J = I + 1 To num - 8
'''            If J > num - 8 Then
'''                Exit For
'''            ElseIf mat(J, 1) = mat1(k, 1) And mat(J, 1)
<> "" Then
'''                k = k +
1
'''                mat1(k, 1) = mat(J,
1)
'''                mat1(k, 2) = mat(J,
2)
'''                mat1(k, 3) = mat(J,
3)
'''                mat(J, 1) =
""
'''                mat(J, 2) =
""
'''                mat(J, 3) =
""
'''            End If
'''        Next J
'''    End
If
'''Next I
For I = 1 To num - 8
    If LenB(mat(I, 1)) Then
    k = k + 1
'!!!!!!!!!!!!
'   D'Où SORT
'mat1'?!!!
'!!!!!!!!!!!!

*********** j'arrête là....., ligne 307

commence par mettre OPTION EXPLICIT tout en haut, tu vas avoir des surprises
bon courage
<hr size="2" width="100%" />Prenez un instant pour répondre à [infomsg_SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009

Mais le truc c'est que ma macro marche très bien la première fois que je la run... Tout vient long si je la reeffectue
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
41
ce qui prouve la célèbre théorie qui dit : un code branlant peut être pire la 2e fois.....
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
9
Salut,

regarde bien la reponse de PCPT, par exemple ici:




'!!!!!!!!!!!!
'   'NUM' ET 'I' NE SONT PAS DéCLARéS?!!!
'!!!!!!!!!!!!




Dim 
num 
As Integer


Dim 

As Integer


For 
I = 

To 
70

    If LenB(Worksheets("Données").Cells(I, 5).Value) = 0 Then
        num = I - 1
        Exit For
    End If
Next 




I






une variable non declaree prend beaucoup de place car comme excel ne sait pas ce que tu vas mettre dedans il lui aloue un maximum de place. Donc la premiere fois excel aloue le maximum de place et la deuxieme fois comme ta variable est encore en memoire il n'y a plus de place a lui donner donc ta macro devient lente. En plus vu la facon dont tu t'y prends ta macro doit scintiller a en fair fermer les yeux d'un aveugle ^^... tu n'es pas systematiquement obliger de selectioner tes celules pour travailler decu par exemple tu peux remplacer :



Worksheets("Présentation").Range("A:A").Select
    Selection.ColumnWidth = 2

par:

Worksheets("Présentation").Range("A:A").ColumnWidth = 2

cela evite le scintillement et cela accelere la macro

Enfin pour definitivement eviter le scintillement et accelerer ta macro en plus de ce qui ta deja ete explique met ce qui suis dans ton code :

Sub ConfigLancement() 'a lancer en debut d'execution




    Application.ScreenUpdating = False 'supprime le scintillement lor de l'execution
   'pour office 2000 ou plus     
   Application.Calculation = xlCalculationManual
   'pour office 97
   On Error Resume Next
   Application.Calculation = xlManual
End Sub

Sub TheEnd() 'retour à la normal a lancer en fin d'execution
   'pour office 2000 ou plus
   Application.Calculation = xlCalculationAutomatic
   'pour office 97
   On Error Resume Next
   Application.Calculation = xlAutomatic 'for excel 97
   Application.ScreenUpdating = True
   End
End Sub

A+
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
18
Tout à fait d'accord avec BigFish.
Évite tous les Select s'ils ne sont pas nécessaires.
ScreenUpdating évite d'afficher les changements "graphiques" donc il y aura accélération, c'est certain.
Calculation est un peu différent selon les macros. Certaines macros ont besoin que les calculs s'effecteunt avant de pouvoir continuer avec des valeurs fiables. Donc à utiliser en toute connaissance de cause...

----------------------------------------
Évite aussi les
If blabla <> blibli Then
    'rien
Else
    'action
End If

Mets plutôt
If blabla = blibli Then
    'action
End If
-----------------------------------------

Mais je comprends ton problème de ralentissement et je n'ai jamais trouvé comment contrer ce ralentissement. L'idée de JMF de sauvegarder est effectivement une bonne méthode mais qui ne règle pas le problème; mais ça ne peut pas nuire. Déclarer les variables comme PCPT le suggère est aussi très important pour l'organisation en mémoire.

Quand on travaille avec Excel toute la journée, ce qui est mon cas, on se rend compte que les macros roulées tôt le matin sont plus rapides que si elles sont roulées en fin de journée... J'ai aussi remarqué (avec Timer) que Office 2000 est environ 20 fois plus rapide que 2003. C'est pas peu dire ...

Mon commentaire n'aidera pas le problème de lenteur d'Excel, mais les conseils qui te sont donnés t'aideront au moins à optimiser ton code... Je vais continuer à suivre ce Post en espérant que quelqu'un trouve la solution magique... Google étant notre ami, je vais tenter d'y trouver des pistes...

MPi²
Pour ceux qui programment sous Office, n'oubliez pas qu'il existe un forum dédié à ces applications VBA.
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009

Ok merci beaucoup pour votre aide... Je vasi essayer tt ça!