[XL-2019] [VBA] Macros trop longues et à optimiser

1 pièce(s) jointe(s)

[VBA] Macros trop longues et à optimiser

Bonjour le forum,

Avec ce que j'ai trouvé sur le net et sur le forum, j'ai réussi a bricoler un macro de retraitement et de mise en forme :aie:
Je vous ai joint un fichier test sinon ce serait trop compliqué à vous expliquer :roll:

Les macros fonctionnent, par contre l'exécution totale met beaucoup de temps (plusieurs minutes)
C'est pour ça que j'ai besoin de votre expertise :mrgreen:

Le but de la macro est, selon le nombre d'onglet EC (X) de réaliser un descriptif à imprimer.
Ce descriptif se remplis via des formule en AF, et pour modifier modifier la police à l’intérieur d'une formule je n'ai trouvé que la méthode suivante :
-Copier/coller les valeurs,
-Réinitialiser la police,
-Appliquer la police souhaitée sur les bouts de textes souhaités (selon police dans la colonne O)

Merci !

Salut,

je doute que des personnes puissent ouvrir un fichier contenant une macro, aussi je t'invite à nous copier ici le code VBA incriminé, et si possible nous indiquer dans quelle partie du pavé il faut qu'on focalise notre attention pour pouvoir t'aider :)

Merci pour nous.

Citation:

Envoyé par Jean-Philippe André

Salut,

je doute que des personnes puissent ouvrir un fichier contenant une macro, aussi je t'invite à nous copier ici le code VBA incriminé, et si possible nous indiquer dans quelle partie du pavé il faut qu'on focalise notre attention pour pouvoir t'aider :)

Merci pour nous.

Vous pouvez quand même l'ouvrir sans activer les macros ?

Ci-dessous tous les codes :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub MEF_descriptif()
   Dim i, NbFeuil As Integer, PasTot As Integer
   Application.ScreenUpdating = False
PasTot = Range("P2")
NbFeuil = 0
For i = 1 To Worksheets.Count 'compte le nombre de feuilles commençant par EC
    If Worksheets(i).Name Like "EC*" And Worksheets(i).Name <> "EC (0)" Then NbFeuil = NbFeuil + 1
Next i
 
For i = 1 To NbFeuil * PasTot Step PasTot
   Range("X12:AE12").Copy
   Range("C" & i + 11, "c" & i + 46).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False
   With Selection
   .Font.Bold = False 'on eleve le gras car après passage la cellule est en gras
   .Font.ColorIndex = 1 'idem que le gras mais selon couleur
   .Copy
   .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'on écrase les formules pour pouvoir rectifier manuellement
   .HorizontalAlignment = xlJustify
   End With
   Range("AF" & i + 2).Copy
    Range("A" & i + 2, "C" & i + 2).Select
    ActiveSheet.Paste
    Chercher_Colorier_plage_liste Range("A" & i + 2, "C" & i + 48), Range("O" & i + 11, "O" & i + 48)
Next
 
MsgBox "Initialisation terminée", vbInformation + vbOKOnly, "Mise en forme"
 
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub Chercher_Colorier_un_un(xrgTxt As Range, xrgQuoi As Range)
' On recherche le texte d'une seule cellule xrgQuoi
' dans le texte de LA cellule xrgTxt
' On recherche toutes les occurences et on leur applique la couleur
' et la graisse de xrgQuoi (caractère par caractère)
 
Dim n&, j&
  If Len(xrgTxt) = 0 Or Len(xrgQuoi) = 0 Then Exit Sub
  n = InStr(1, xrgTxt, xrgQuoi, vbTextCompare)
  Do While n > 0
    For j = 0 To Len(xrgQuoi) - 1
      With xrgTxt.Characters(Start:=n + j, Length:=1).Font
        .FontStyle = xrgQuoi.Characters(Start:=j + 1, Length:=1).Font.FontStyle
        .Color = xrgQuoi.Characters(Start:=j + 1, Length:=1).Font.Color
      End With
    Next j
    n = InStr(n + Len(xrgQuoi), xrgTxt, xrgQuoi, vbTextCompare)
  Loop
End Sub
 
Sub Chercher_Colorier_un_liste(xrgTxt As Range, xrgQuoi As Range)
' idem précédent mais pour plusieurs textes à rechercher
' xrgTxt est une cellule et xrgQuoi est une plage de cellules
Dim xcell As Range
  If Len(xrgTxt) = 0 Then Exit Sub
  For Each xcell In xrgQuoi
    If Len(xcell) > 0 Then Chercher_Colorier_un_un xrgTxt, xcell
  Next xcell
End Sub
 
Sub Chercher_Colorier_plage_liste(xrgTxt As Range, xrgQuoi As Range)
' idem précédent mais on recherche au sein d'une plage de cellule xrgTxt.
' C'est le cas le plus général: on recherche au sein de toute la plage xrgTxt
' chaque mot de la plage xrgQuoi et on applique la mise en forme graisse et couleur
 
Dim xcell As Range, old As Boolean
  old = Application.ScreenUpdating: Application.ScreenUpdating = False
  For Each xcell In xrgTxt
    Chercher_Colorier_un_liste xcell, xrgQuoi
  Next xcell
  Application.ScreenUpdating = old
End Sub

Une piste intéressante je pense pourrait être de ne pas appliquer la macro Chercher_Colorier_plage_liste sur les lignes masquées. (je ne sais pas comment le faire)(les lignes masquées sont celles où la colonne N = 0)

En effet, avant de lancer la macro MEF_descriptif, je masque toutes les lignes non concernées (mais le code s’applique quand même dessus.