Optimisation et simplification de maquereau
bonjour à tous, j'espère que vous allez bien. Je vous souhaite une bonne année 2021 🎉🎉🎉
Je viens vers vous car j'ai développer une macro mais elle met beaucoup trop de temps à se réaliser (environ 50 secondes) . J'aimerais savoir lesquels point je pourrais simplifier pour améliorer le temps de résolution de la Macro.
cette micro permet à partir de plusieurs données faire des études et regrouper des informations pour imprimer un plan de maintenance préventive.
je préviens d'avance le code n'est pas parfait, je suis encore qu'un débutant.
Sub Bouton7_Cliquer()
' Affichage des onglets + frise de l'écran
Application.ScreenUpdating = False
Sheets("calcul2").Visible = True
Sheets("donné2").Visible = True
Sheets("PMP").Visible = True
If Sheets("donné2").Range("l1") = 1 Then 'Vérification si possibilité d'effectuer la macro
Dim tableauadresse As Range, ref As String, refdos As String, rafale As String, Rfait As String, copietete As String 'Mise en place des variables
ref = Sheets("HOME").Range("AV30").Value 'Recherche de la valeur Ref
Application.Calculation = xlCalculationManual 'Arrêt des calculs automatiques pour éviter tout problème
Sheets("PMP").Select
With Application 'Bloquer tout affichage de messages d'erreur
.ScreenUpdating = False
.DisplayAlerts = False
End With
ActiveWindow.SelectedSheets.Delete 'L'arrêt des calculs automatiques plus bloquait message d'erreur permet supprimé la feuille PMP sans problème.
Sheets("donné2").Select
Dim saveEX As String, SavePresse As String, savegamme As String
Sheets("donné2").Range("e2:e9999").Find(ref).Select 'Recherche de référence dans un tableau
'Puis relever les références pour les mettre dans les variables.
ActiveCell.Offset(0, -1).Select
refdos = ActiveCell.Value
ActiveCell.Offset(0, 2).Select
rafale = ActiveCell.Value
ActiveCell.Offset(0, 2).Select
Rfait = ActiveCell.Value
1 Rfait = Rfait + 1
ActiveCell.Value = Rfait
ActiveCell.Offset(0, -5).Select
SavePresse = ActiveCell.Value
ActiveCell.Offset(0, 8).Select
saveEX = ActiveCell.Value
ActiveCell.Offset(0, -4).Select
savegamme = ActiveCell.Value
'Ouverture du fichier concerné
Workbooks.Open Filename:= _
"I:\Dir_Indus_Chassis\Dpt_79_81\AT_GATO\GATO\DOCS COMMUNS GATO\PMP\Chantier REE\Nouveaux PMP révision\nouvelle pmp\" & saveEX & "\" & SavePresse & "\" & savegamme & "\" & refdos & ".xlsm"
Windows("Feuille PMP").Activate
'Copie de la feuille du fichier qui était ouvert
Windows(refdos & ".xlsm").Activate
Sheets("PMP").Select
Sheets("PMP").Copy Before:=Workbooks("Feuille PMP.xlsm"). _
Sheets(8)
Sheets("PMP").Select
Windows(refdos & ".xlsm").Activate
ActiveWindow.Close SaveChanges:=False 'Fermeture du fichier qui a été ouvert
Windows("Feuille PMP").Activate
Sheets("calcul2").Activate
Range("a1").Value = rafale
Range("C2").Value = Rfait
'lite en ligne de la pmp
Dim fh As Worksheet, fc As Worksheet, tablo, tabloR()
Sheets("HOME").Select
Dim i&, j&, k&
Dim ligne As Long
ligne = Sheets("HOME").Range("BE99999").End(xlUp).Row + 1
Sheets("HOME").Range("BE29" & ":BK" & ligne).Select
Selection.ClearContents
Sheets("calcul2").Select
Sheets("calcul2").Activate
Range("A:O").Select
Application.Calculation = xlCalculationAutomatic 'Et réactivation du calcul automatique plus remplacement de toutes les erreurs F
Columns("C:C").Select
Selection.Replace What:="#REF", Replacement:="PMP", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Columns("i:O").Select
Selection.Replace What:="#REF", Replacement:="PMP", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Columns("T:T").Select
Selection.Replace What:="#REF", Replacement:="PMP", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
If Range("H1") > 0 Then 'Mise en tableau de toutes les données de la feuille de calcul2 et affichage sur la feuille Home
tablo = Range("I3:O" & Range("I" & Rows.Count).End(xlUp).Row)
Set fh = Sheets("Home")
Set fc = Sheets("calcul2")
k = 0
For i = 1 To UBound(tablo, 1)
If tablo(i, 1) & tablo(i, 2) & tablo(i, 3) & tablo(i, 4) & tablo(i, 5) _
& tablo(i, 6) & tablo(i, 7) <> "" Then
ReDim Preserve tabloR(1 To 7, 1 To k + 1)
For j = 1 To 7
tabloR(j, k + 1) = tablo(i, j)
Next j
k = k + 1
End If
Next i
fh.Range("BE29:BK" & Rows.Count).ClearContents
fh.Range("BE29").Resize(UBound(tabloR, 2), 7) = Application.Transpose(tabloR)
fh.Activate
Dim presse As String, gamme As String, dési As String, numin As String, numpi As String, numPMP As String
Sheets("PMP").Activate
'Recherche de toutes les valeurs intéressantes à ajouter dans la feuille à imprimer
presse = Range("G3").Value
dési = Range("B3").Value
gamme = Range("B5").Value
numin = Range("J3").Value
numpi = Range("C5").Value
Sheets("feille a imprimé").Activate
Range("a4").Value = dési
Range("a5").Value = gamme
Range("D4").Value = presse
Range("B5").Value = numpi
Range("H4").Value = numin
Range("H6").Value = Rfait
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("HOME").Activate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End If
'Partie de mise en forme pour la feuille imprimée, cette partie permet de créer des cases en fonction de ce qui remplit dans la colonne A
Dim ligne3 As Long 'calcul2
Dim ligne2 As Long ' feille a imprimé
Dim trais As Long ' calcul2 pour la fin for
Dim info1 As String, info2 As String, temp As String, tete As String, infotes1 As String, infotes2 As String, verif As String
Sheets("calcul2").Select
ligne3 = 3
ligne2 = 20
Sheets("feille a imprimé").Select
Range("A20:h1000").Select
Selection.Clear
Sheets("calcul2").Select
If Sheets("calcul2").Range("h1") = 0 Then
MsgBox "pas de pmp a faire"
Else
For i = 3 To 200 'Répétition de 200 fois pour faire toutes les valeurs du tableau
If Sheets("calcul2").Range("U" & ligne3) = 0 Then
ligne3 = ligne3 + 1
Else
'Si dans la colonne eue la ligne correspondant est égale à 1 alors ceci est considérée comme un début de partie
If Sheets("calcul2").Range("u" & ligne3) = 1 Then
info1 = Sheets("calcul2").Range("u" & ligne3).Offset(0, -12).Value
info2 = Sheets("calcul2").Range("u" & ligne3).Offset(0, -6).Value
temp = Sheets("calcul2").Range("u" & ligne3).Offset(0, -8).Value
Sheets("feille a imprimé").Range("a" & ligne2) = info1
Sheets("feille a imprimé").Select
Sheets("feille a imprimé").Range("E" & ligne2).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Sheets("feille a imprimé").Range("g" & ligne2).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ligne2 = ligne2 + 1
Sheets("feille a imprimé").Range("a" & ligne2) = info2
Sheets("feille a imprimé").Range("D" & ligne2) = temp & "'"
ligne3 = ligne3 + 1
ligne2 = ligne2 + 2
Else
'Si la valeur dans la colonne U correspond à 2 cela veut donc dire que la valeur est juste une information
If Sheets("calcul2").Range("u" & ligne3) = 2 Then
tete = Sheets("calcul2").Range("u" & ligne3).Offset(0, -12).Value
Sheets("feille a imprimé").Select
Range("a" & ligne2) = tete
trais = ligne2 - 1
Range("A16:h" & trais).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
ligne3 = ligne3 + 1
ligne2 = ligne2 + 2
End If
End If
End If
Next
'Mise en page d'un espace commentaire
Sheets("feille a imprimé").Range("A" & ligne2).Value = "COMMENTAIRE :"
trais = ligne2 - 1
Range("A16:h" & trais).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
trais = ligne2 + 11
Range("A16:h" & trais).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
If Sheets("feille a imprimé").Range("BM29").Value = 1 Then
'Si le type de presse est une presse progressif alors utiliser la mise en forme ci-dessous
Sheets("feille a imprimé").Select
Sheets("feille a imprimé").Range("a2:a9999").Find("Partie sup:").Select
With Selection.Font
.Name = "Calibri"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Sheets("feille a imprimé").Range("a2:a9999").Find("Partie inf:").Select
With Selection.Font
.Name = "Calibri"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Else
'Si le type de presse est une transfert alors utiliser la mise en forme ci-dessous
Sheets("feille a imprimé").Range("a2:a9999").Find("Partie sup:").Select
With Selection.Font
.Name = "Calibri"
.Size = 26
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Sheets("feille a imprimé").Range("a2:a9999").Find("Partie inf:").Select
With Selection.Font
.Name = "Calibri"
.Size = 26
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Dim OPX As String
OPX = 10
On Error Resume Next 'Il est possible qu'il manque des OP et ils se comptent de 10 en 10 C'est pour cela qu'un code erreur a été rajouté
For i = 1 To 20
Sheets("feille a imprimé").Range("a2:a9999").Find("OP " & OPX & ":").Select
With Selection.Font
.Name = "Calibri"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Err.Clear
OPX = OPX + 10
Next
End If
End If
Else
MsgBox "le numéreau de piéce n'ai pas enregistrer" 'Fin du tout premier SI
End If
'Masquage des onglets
Sheets("calcul2").Visible = False
Sheets("donné2").Visible = False
Sheets("PMP").Visible = False
'Remise de l'actualisation d'écran
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("HOME").Select
End Sub3
Bonjour Cheve, et bonjour aux maquereaux et maquerelles aussi,
C'est un record de longueur votre macro ! Je doute que quelqu'un se risque à plonger le nez dedans malheureusement... Vous devriez la scinder en plusieurs procédures distinctes et toutes les exécuter à partir d'une macro principal, ce serait plus simple. Par exemple, vous devriez réserver un module pour les mises en forme.
Pour le temps d'exécution, il faut déjà bannir tous les .select et activecell qui n'ont pas d'utilité dans 99% des cas.
Cdlt,
Merci beaucoup 3gb je vais faire sa 😉