Microsoft 365 Si cellule sélectionner alors mettre de la couleur sur les autres cellules de même nom

niglo

XLDnaute Nouveau
Bonjour,

j'ai 3 tableaux dans une feuille, dans ces tableaux j'ai des noms qui sont identiques.
Ce que je souhaiterai c'est que lorsque je met une couleur sur un nom dans le tableau 1 le même nom qui se trouve dans les tableaux 2 et 3 soit mis avec une autre policy et remplissage.

Merci d'avance de votre aide, en espérant avoir été assez clair !

Bonne journée
 

Pièces jointes

  • Classeur1.xlsx
    12.7 KB · Affichages: 6

JBARBE

XLDnaute Barbatruc
Bonjour à tous toutes,
Peut-être ceci avec 2 manques chez toi je pense (abdelkrime et pascal)!
1033108


Bonne journée !
 

Pièces jointes

  • Classeur1-1.xlsm
    25.2 KB · Affichages: 4

niglo

XLDnaute Nouveau
Bonjour à tous toutes,
Peut-être ceci avec 2 manques chez toi je pense (abdelkrime et pascal)!
Regarde la pièce jointe 1033108

Bonne journée !
ROOOOOOOh vous êtes trop fort !! c'est exactement ça !!
Si je peux abuser ...
comment faire pour annuler / reset, j'explique j'ai sélectionner la mauvaise ligne mais je me suis aperçue qu’après avoir fait "GO" , je change ma sélection avec une autres lignes et je refais "GO" malheureusement les anciens noms sont toujours en noir.

Merci Merci et encore Merci du temps que vous m'accordez !!
 

JBARBE

XLDnaute Barbatruc
Re,
Tout à bord un message s'affiche pour demander si l'on veut effacer ( pour plus de sécurité )
Dans ma macro et pour pouvoir l'exporter sur d'autre fichier il faut (un tout petit peu de notion VBA) :
-changer les Numéros des lignes et des colonnes présentent !
- Changer le nom de la feuille ( ici feuil1)
Je prépare la description dans la macro !
 

Pièces jointes

  • Classeur1-1.xlsm
    26.4 KB · Affichages: 1

JBARBE

XLDnaute Barbatruc
Re,
Ne tenir compte que des lignes, colonnes et feuille en vert (jaune ici) dans la macro pour reporter dans un autre tableau avec des dimensions différentes !
VB:
Option Explicit

Sub TEST()
Dim i As Long, j As Long, k As Long, l As Long
Application.ScreenUpdating = False
For i = 2 To 6 ' colonnes de 2 à 6 (B à F)
 For k = 5 To 7 ' lignes de 5 à 7
 If Cells(k, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6
  If Cells(k, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
  End If
 Next j
 End If
 Next k
 
 For l = 11 To 13 ' lignes de 11 à 13
 If Cells(l, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6 (B à F)
  If Cells(l, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
  End If
 Next j
 End If
 Next l
Next i
Application.ScreenUpdating = True
End Sub

Sub effacer()
Dim vReponse As String
vReponse = MsgBox("Voulez-vous effacer ?", vbYesNo + vbQuestion)
If vReponse = vbYes Then
Sheets("Feuil1").Range("B5:F18").Interior.ColorIndex = xlNone ' feuille 1 et cellules ( tableau B5-F18)
Sheets("Feuil1").Range("B5:F18").Font.ColorIndex = 1 ' feuille 1 et cellules ( tableau B5-F18)
Else
Exit Sub
End If
End Sub
 

Pièces jointes

  • Classeur1-1.xlsm
    27.9 KB · Affichages: 4
Dernière édition:

niglo

XLDnaute Nouveau
Re,
Ne tenir compte que des lignes, colonnes et feuille en vert (jaune ici) dans la macro pour reporter dans un autre tableau avec des dimensions différentes !
VB:
Option Explicit

Sub TEST()
Dim i As Long, j As Long, k As Long, l As Long
Application.ScreenUpdating = False
For i = 2 To 6 ' colonnes de 2 à 6 (B à F)
For k = 5 To 7 ' lignes de 5 à 7
If Cells(k, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6
  If Cells(k, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
  End If
  If Cells(k, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
  End If
Next j
End If
Next k

For l = 11 To 13 ' lignes de 11 à 13
If Cells(l, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6 (B à F)
  If Cells(l, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
  Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
  Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
  Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
  Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
  Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
  End If
  If Cells(l, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
  Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
  End If
Next j
End If
Next l
Next i
Application.ScreenUpdating = True
End Sub

Sub effacer()
Dim vReponse As String
vReponse = MsgBox("Voulez-vous effacer ?", vbYesNo + vbQuestion)
If vReponse = vbYes Then
Sheets("Feuil1").Range("B5:F18").Interior.ColorIndex = xlNone ' feuille 1 et cellules ( tableau B5-F18)
Sheets("Feuil1").Range("B5:F18").Font.ColorIndex = 1 ' feuille 1 et cellules ( tableau B5-F18)
Else
Exit Sub
End If
End Sub

Merci c'est vraiment cool d'avoir pris du temps pour me repondre

Bonne soirée
 

Discussions similaires

Statistiques des forums

Discussions
311 740
Messages
2 082 047
Membres
101 880
dernier inscrit
Anton_2024