Discussion :

[Anthony47]

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
Je vous ai joint un fichier test sinon ce serait trop compliqué à vous expliquer

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

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 !

[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.

[Anthony47]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Anthony47]

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.