Problème de rapidité
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
-
3 janv. 2008 à 11:08
Amartin6 Messages postés 44 Date d'inscription dimanche 30 décembre 2007 Statut Membre Dernière intervention 21 septembre 2009 - 4 janv. 2008 à 17:02
Amartin6 Messages postés 44 Date d'inscription dimanche 30 décembre 2007 Statut Membre Dernière intervention 21 septembre 2009 - 4 janv. 2008 à 17:02
13 réponses
cs_MPi
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
17 août 2018
23
3 janv. 2008 à 11:20
3 janv. 2008 à 11:20
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.
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.
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
3 janv. 2008 à 11:27
3 janv. 2008 à 11:27
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?
Ne vois tu rien qui pourrait vider la mémoire?
jmfmarques
Messages postés
7666
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
27
3 janv. 2008 à 12:36
3 janv. 2008 à 12:36
Essaye d'enregistrer ton classeur entre 2 exécutions de cette macro...
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
3 janv. 2008 à 13:05
3 janv. 2008 à 13:05
J'avais déjà essayé mais cela ne change rien! Auriez-vous d'autres solutions?
Merci d'avance
Merci d'avance
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
jmfmarques
Messages postés
7666
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
27
3 janv. 2008 à 13:39
3 janv. 2008 à 13:39
"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 !
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 !
PCPT
Messages postés
13272
Date d'inscription
lundi 13 décembre 2004
Statut
Membre
Dernière intervention
3 février 2018
47
3 janv. 2008 à 14:13
3 janv. 2008 à 14:13
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
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
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
3 janv. 2008 à 14:45
3 janv. 2008 à 14:45
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
'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
PCPT
Messages postés
13272
Date d'inscription
lundi 13 décembre 2004
Statut
Membre
Dernière intervention
3 février 2018
47
3 janv. 2008 à 15:34
3 janv. 2008 à 15:34
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
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
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
3 janv. 2008 à 15:49
3 janv. 2008 à 15:49
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
PCPT
Messages postés
13272
Date d'inscription
lundi 13 décembre 2004
Statut
Membre
Dernière intervention
3 février 2018
47
3 janv. 2008 à 16:09
3 janv. 2008 à 16:09
ce qui prouve la célèbre théorie qui dit : un code branlant peut être pire la 2e fois.....
bigfish_le vrai
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
15
3 janv. 2008 à 16:44
3 janv. 2008 à 16:44
Salut,
regarde bien la reponse de PCPT, par exemple ici:
'!!!!!!!!!!!!
' '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
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+
regarde bien la reponse de PCPT, par exemple ici:
'!!!!!!!!!!!!
' '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
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+
cs_MPi
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
17 août 2018
23
4 janv. 2008 à 00:24
4 janv. 2008 à 00:24
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.
É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.
Amartin6
Messages postés
44
Date d'inscription
dimanche 30 décembre 2007
Statut
Membre
Dernière intervention
21 septembre 2009
4 janv. 2008 à 17:02
4 janv. 2008 à 17:02
Ok merci beaucoup pour votre aide... Je vasi essayer tt ça!