Formater des cellules en fonction des données d'une feuille (VBA)

Version imprimable

1 pièce(s) jointe(s)

Boujour,
j'ai un classeur avec plusieurs feuilles. Dans la première feuilles, j'ai une liste de terme dans la colonne A et dans la colonne B, le format que je souhaite avoir.
Pièce jointe 213554

Dans mes autres feuilles, j'aimerai que chaque cellule contenant le mot exacte de ma liste ci-dessus, prenne le format indiqué dans la liste.
(Je sais qu'il existe les format conditionnelles mais j'ai bcp de feuilles et beaucoups d'onglet, ce qui n'est pas pratique du tout.)
Je ne pense pas que ça soit bien compliqué mais comme je n'utilise quasiment jamais au VBA, je rame un peu...

Voilà où j'en suis dans mes tentatives :aie: :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Private Sub Worksheet_Change(ByVal Target As Range) Dim L As Integer L = 2 While L < 80 If ActiveCell.Value = Sheets("Liste").Cells(L, 1).Value Then Sheets("Liste").Cells(L, 2).Select Selection.Copy ActiveSheet.ActiveCell.Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End If L = L + 1 Wend End Sub
Pouvez vous m'aider s'il vous plait ?
Merci d'avance

22/06/2016, 01h15
jurassic pork

hello,
il y a quelque chose dans ta demande que je ne comprend pas :aie: . Si ce que tu appelles le mot exact est un mot de la colonne A projets, dans ce que tu nous montres il y a plusieurs fois la même valeur (ex: T1) avec un format différent ?

Ami calmant, J.P
22/06/2016, 01h23
Marjo38

Oui pardon, c'est une erreur quand j'ai fait le screenshot. Il y a bien des projets différents dans ma colonne A. Il n'y à donc pas de "concurrence" entre les items.

1 pièce(s) jointe(s)

Bonsoir,
j'ai mis des formats au hasard mais sur la colonne de recherche (A), donc ce code suffit, dans "ThisWorkBook"

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim x As Long
If Sh.Name <> "Liste" Then
  For x = 1 To 80
    If Target.Value = Sheets("Liste").Range("A" & x).Value Then
      Application.EnableEvents = False
      Sheets("Liste").Range("A" & x).Copy Target
      Exit For
      Application.EnableEvents = True
    End If
  Next
End If
End Sub

ouvres ce fichier si tu veux

1 pièce(s) jointe(s)

Bonjour et merci pour votre intervention.
Cependant, j'ai plusieurs problème. Je tient vraiment à avoir deux collones, une de texte et une de format pour une meilleurs lisibilité (je compte avoir des format avec des hachures).

Et quand je modifie votre code ca ne marche déja plus !!
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim x As Long If Sh.Name <> "Liste" Then For x = 1 To 80 If Target.Value = Sheets("Liste").Range("A" & x).Value Then Application.EnableEvents = False Sheets("Liste").Range("B" & x).Copy Target Exit For Application.EnableEvents = True End If Next End If End Sub
En faite, même en reprenant exactement votre code dans un nouveau classeur, ça ne fonctionne plus !
Pièce jointe 213611

Bref, je me demande s'il n'y a pas d'option a activer. J'ai pourtant autorisé toute les macros...

Citation:

Cependant, j'ai plusieurs problème. Je tient vraiment à avoir deux collones, une de texte et une de format pour une meilleurs lisibilité (je compte avoir des format avec des hachures).

je vais y regarder mais le code va s'alourdir, quant aux hachures, ça ne devrait pas causer de problème

essayes cette procédure, toujours dans "ThisWorkBook"
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim x As Long If Sh.Name <> "Liste" Then For x = 1 To 80 If Target.Value = Sheets("Liste").Range("A" & x).Value Then Application.EnableEvents = False Sheets("Liste").Range("B" & x).Copy Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.EnableEvents = True Exit For End If Next End If End Sub

22/06/2016, 16h10
Marjo38

1 pièce(s) jointe(s)

Hoo merci, ça marche bien (Si je comprend bien c'est le application.enableEvents qui restait ouvert)..
Mais je constate que dés que je fait un copier collée de plusieurs cellules, la macro n'arrive plus à suivre et plante. "Erreur d'execution '13': Incompatibilité de type.
Du coup, je me demande s'il ne faudrait pas modifier la macro pour qu'elle s’exécute sur une zone de la feuille et que tout les formats de ces cellules soit rafraichit.
Peut on faire en sorte que la macro ne s’exécute que pour les cellules A4 à O100, au moment où je sauvegarde (et change d'onglet) par exemple? Cela permettrait de :
-pouvoir faire de copier coller sans bug
-rafraichir tout les formats des feuilles si je modifie la feuille liste

Voici mon fichier
Pièce jointe 213651
22/06/2016, 16h13
casefayere

Citation:

Peut on faire en sorte que la macro ne s’exécute que pour les cellules A4 à O100, au moment où je sauvegarde par exemple? Cela permettrait de :
-pouvoir faire de copier coller sans bug
-rafraichir tout les formats des feuilles si je modifie la feuille liste

oui, c'est comme assan cf, c'est possible, là je suis en pause, je tonds le jardin sous un soleil de plomb, alors j'espère revoir tout ça, ce soir

Haha je comprend !! Profitez bien du beau temps ;)
Merci et à plus tard alors

J'ai trouver un truc qui "marche", mais ça n'est peut être pas optimal :

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
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim x As Long
Dim l As Long
Dim c As Long
 
For l = 4 To 150
For c = 1 To 15
 
 
    If Sh.Name = "Synthèse" Then Exit Sub
 
    If Sh.Name <> "Liste" Then
     For x = 1 To 80
'Mets le fond en blanc et l'écriture en noir
     Sh.Cells(l, c).Interior.ColorIndex = 2 
     Sh.Cells(l, c).Font.ColorIndex = 1
 
'Si vide, ne rien faire (fond blanc police noir)
       If IsEmpty(Sh.Cells(l, c)) Then Exit For
 
'Si égale a ma liste, alors copier format
       If Sh.Cells(l, c) = Sheets("Liste").Range("A" & x).Value Then
          Application.EnableEvents = False
          Sheets("Liste").Range("B" & x).Copy
          Sh.Cells(l, c).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
          Application.EnableEvents = True
          Exit For
        End If
      Next x
 
    End If
 
Next c
Next l
 
End Sub

J'essai de l'adapté pour que ma macro s'effectue sur chaque page de mon classeur avant l'enregistrement, mais ca ne marche pas.... Peut on m'aider, s'il vous plait ?

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
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Dim i As Integer 'onglet
Dim j As Integer 'nbr d'onglets total
Dim x As Long 'Lignes de la liste projet
Dim l As Long 'nbr de lignes à formater
Dim c As Long 'nbr de colonnes à formater
 
'A chaque feuille
j = Worksheets.Count
j = j - 1
    For i = 2 To j
 
 'Scan les cellules de la feuille
        For l = 6 To 113 ' de la ligne 6 à 113
        For c = 1 To 15  ' de la colonne A à O
 
            Worksheets(i).Activate
            If Worksheets(i).Name <> "Liste" Or Worksheets(i).Name <> "Synthèse" Then
             For x = 1 To 70
               If IsEmpty(Worksheets(i).Cells(l, c)) Then Worksheets(i).Cells(l, c).Interior.ColorIndex = 2
               Exit For
 
               If Worksheets(i).Cells(l, c) = Sheets("Liste").Range("A" & x).Value Then
                  Application.EnableEvents = False
                  Sheets("Liste").Range("B" & x).Copy
                  Worksheets(i).Cells(l, c).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
                  Application.EnableEvents = True
                  Exit For
                End If
              Next x
 
            End If
 
        Next c
        Next l
 
    Next i
End Sub

23/06/2016, 11h43
casefayere

Citation:

Mais je constate que dés que je fait un copier collée de plusieurs cellules, la macro n'arrive plus à suivre et plante. "Erreur d'execution '13': Incompatibilité de type.

à partir de quelles cellules et de quelle feuille les "Copier/Coller ?

Citation:

Peut on faire en sorte que la macro ne s’exécute que pour les cellules A4 à O100, au moment où je sauvegarde (et change d'onglet) par exemple? Cela permettrait de :
-pouvoir faire de copier coller sans bug
-rafraichir tout les formats des feuilles si je modifie la feuille liste

donc avec un autre évènement que "Change ? ça sera plus facile

Citation:

-pouvoir faire de copier coller sans bug

en conséquence, tu risqueras moins

Citation:

-rafraichir tout les formats des feuilles si je modifie la feuille liste

ça sera automatique si tu change d'évènement, exemple, un bouton de commande
23/06/2016, 14h17
Marjo38

Citation:

à partir de quelles cellules et de quelle feuille les "Copier/Coller ?

Dans les feuilles qui ne sont pas "Liste" n'importe quel copier coller. Dés que l'on change plus d'une cellule en même temps (si tu colle deux cellule par exemple) le target ne sait plus quoi cibler, et donc plantage.

Citation:

Peut on faire en sorte que la macro ne s’exécute que pour les cellules A4 à O100, au moment où je sauvegarde (et change d'onglet) par exemple? Cela permettrait de :
-pouvoir faire de copier coller sans bug
-rafraichir tout les formats des feuilles si je modifie la feuille liste
donc avec un autre évènement que "Change ? ça sera plus facile

J'ai réussi en le mettant dans un evenement sauvegarde, mais la macro est trop longue. Car je lui dit de boucler le copier coller sur chaque cellule entra A4 et O100 puis de changer de feuilles. Il y as peut être une maniére plus élégante que la mienne. Ce fichier doit être utilisé par plusieurs personnes donc si chaque sauvegarde prend 5 min, ça ne va pas le faire.
23/06/2016, 14h52
casefayere

dès que j'aurai du temps, j'essayerai de te préparer un code provoqué par un bouton de commande, si tu ne veux pas de bouton, libre à toi de garder le code, supprimer le bouton et intégrer le code dans un autre évènement que "Change"

brut de brut, ça devrait donner ça, mais le temps à l'exécution risque d'être très long, il faudrait pouvoir passer par des tableaux mais comment stocker les divers formats dedans (formats police, remplissage, motifs, etc;) ouille, ouille !!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Sub CommandButton1_Click()
Dim x As Long, Ws As Worksheet, Plg As Range, Cel As Range, cel1 As Range, Plg1 As Range, Dcel As Long
With Sheets("Liste")
  Dcel = .Range("A" & .Rows.Count).End(xlUp).Row
  Set Plg1 = .Range("A2", "A" & Dcel)
End With
For Each Ws In Worksheets
  If Ws.Name <> "Synthèse" And Ws.Name <> "Liste" Then
    Set Plg = Ws.Range("A4:O100")
    For Each Cel In Plg
      For Each cel1 In Plg1
        If Cel = cel1 Then
          cel1(1, 2).Copy
          Cel.PasteSpecial Paste:=xlPasteFormats
        End If
      Next cel1
    Next Cel
  End If
Next Ws
 
End Sub

Bonjour,
Merci beaucoup pour votre aide, j'ai une macro qui fonctionne bien! (il me reste plus qu'a trouver la commande pour effacer le motif d'une cellule dans toucher aux bordures).

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
Private Sub CommandButton1_Click()
Dim x As Long
Dim l As Long
Dim c As Long
 
For l = 4 To 150
For c = 1 To 15
 
 
    If ActiveSheet.Name = "Synthèse" Then Exit Sub
 
    If ActiveSheet.Name <> "Liste" Then
     For x = 1 To 100
       If IsEmpty(ActiveSheet.Cells(l, c)) Then
    ActiveSheet.Cells(l, c).Interior.ColorIndex = 2
    ActiveSheet.Cells(l, c).Interior.PatternColor = RGB(0, 0, 0)
    ActiveSheet.Cells(l, c).Font.ColorIndex = 1
     Exit For
     End If
       If ActiveSheet.Cells(l, c) = Sheets("Liste").Range("A" & x).Value Then
          Application.EnableEvents = False
          Sheets("Liste").Range("B" & x).Copy
          ActiveSheet.Cells(l, c).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
          Application.EnableEvents = True
          Exit For
       End If
      Next x
 
    End If
 
Next c
Next l
End Sub

Bonsoir le fil :P

Ici, je ne traite qu'une seule feuille, tu peux l'adapter en changeant d'événement ;)

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
Private Sub Worksheet_Activate()
Dim rng As Range, r As Range, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Liste")
        For Each r In .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            dico.Item(r.Value) = VBA.Array(r.Interior.ColorIndex, r.Font.ColorIndex)
        Next
    End With
    Application.ScreenUpdating = False
    Set rng = Range("a3:d12")
    With rng
        .Interior.ColorIndex = xlNone
        .Font.ColorIndex = 1
    End With
    If Not rng Is Nothing Then
        For Each r In rng
            If Not IsEmpty(r) Then
                If dico.exists(r.Value) Then
                    r.Interior.ColorIndex = dico.Item(r.Value)(0)
                    r.Font.ColorIndex = dico.Item(r.Value)(1)
                End If
            End If
        Next
    End If
    Set rng = Nothing
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89