XL 2013 report de cellule quand je la rempli (couleur)

fred347

XLDnaute Nouveau
Bonjours a tous
Je suis nouveau sur le forum

Et j’ai besoin d’un peu d’aide
Mon classeur ce divise en 3 catégories
· Visuel
· Energie
· Capacité

Mon problème est celui-ci :
Je voudrais pouvoir faire du remplissage (couleur) de cellule dans :
· 2 énergies (colonne C)
· 3 énergies (colonne C)
· 4 énergies (colonne C
· Geme énergie (colonne D, G, J)
· 2 capacités (colonne E)
· 3 capacités (colonne E)
· 4 capacités (colonne E)
· Geme capacités (D, E, O)

Et que sa se retrouve dans la feuille « visuel »
Les chiffres que j’ai dans ma pages visuel sont les même que dans les autres classeurs sauf qu’elles sont triés

En gros je veux mètre des case rouge sur mes chiffres (énergie et capacité) et que sa je le vois dans mon visuel

ci je met sur 2energie mon 4.5 (c7) en rouge
upload_2016-7-22_12-13-9.png

je voudrai que dans visuel il soit rouge aussi
upload_2016-7-22_12-14-54.png
merci a tous d’avance
 

Fichiers joints

Jacky67

XLDnaute Accro
pas de réponse ??
Bonjour,
Un début de réponse par VBA pour les parties "energie " et "capacité"
J'ai renommé la feuille "4 énergie" en "4 energie"
Comme il y a des doublons et pas de comparaison possible, ce sera la première donnée du même nombre qui sera prise en compte. Je ne suis pas certain que cela soit le résultat souhaité.:(
Pour le reste, si on peut déplacer les données de la feuille · Geme capacités (D, E, O)
en · Geme capacités (colonne D, G, J), ....peut-être :rolleyes:
Salutations
JJ
 

Fichiers joints

Dernière édition:

fred347

XLDnaute Nouveau
bonjour,
un grand merci a toi jacky67
c'est tout a fait ce qu'il me fallait
oui il est possible de déplacer les 3 colonnes geme capacite ( même ci je n'ai pas compris ou tu voulez les mettre lol).
mais juste une petite question supplémentairement , comment a tu fait a t'il un tuto pour faire ce genre de (calcul)
 

job75

XLDnaute Barbatruc
Bonjour fred347, Jaccky67,

Dans cette affaire la vraie difficulté a été de copier les valeurs dans la feuille "visuel" (les trier comme vous dites).

Comment feriez-vous s'il y en a des milliers, voire des dizaines de milliers ???

Une fois que cela est fait correctement copier les couleurs n'est pas trop difficile.

Il faut commencer par nommer les colonnes sources (Source1 à Source12) et les colonnes des destination (Dest1 à Dest12).

Ensuite placer cette macro dans le code de la feuille "visuel" :
Code:
Private Sub Worksheet_Activate()
Dim i As Byte, Source As Range, Dest As Range, n&, c As Range, p&, j&
Application.ScreenUpdating = False
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Dest.Parent.UsedRange.EntireRow)
  If Dest.Count > 3 Then Dest(4).Resize(Dest.Count - 3).Interior.ColorIndex = xlNone 'RAZ
  n = 0
  For Each c In Source
  If c <> "" Then
  n = n + 1
  If c.Interior.ColorIndex <> xlNone Then
  p = 0
  For j = 4 To Dest.Count
  If Dest(j) <> "" Then
  p = p + 1
  If p = n Then Dest(j).Interior.Color = c.Interior.Color: Exit For
  End If
  Next
  End If
  End If
Next c, i
End Sub
La macro s'exécute quand on active la feuille.

Fichier joint.

A+
 

Fichiers joints

Dernière édition:

fred347

XLDnaute Nouveau
salut ,
oui c'est bien normal que C4,C5,C6, =4 petite explication
upload_2016-7-24_18-16-54.png
n'est t'il pas possible de faire un "si alors sinon" si le premier est fait, passer a l'autre?
j’espère que mes explication sont claire
merci encore
 

fred347

XLDnaute Nouveau
Bonjour fred347, Jaccky67,

Dans cette affaire la vraie difficulté a été de copier les valeurs dans la feuille "visuel" (les trier comme vous dites).

Comment feriez-vous s'il y en a des milliers, voire des dizaines de milliers ???

Une fois que cela est fait correctement copier les couleurs n'est pas trop difficile.

Il faut commencer par nommer les colonnes sources (Source1 à Source12) et les colonnes des destination (Dest1 à Dest12).

Ensuite placer cette macro dans le code de la feuille "visuel" :
Code:
Private Sub Worksheet_Activate()
Dim i As Byte, Source As Range, Dest As Range, n&, c As Range, p&, j&
Application.ScreenUpdating = False
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Dest.Parent.UsedRange.EntireRow)
  If Dest.Count > 3 Then Dest(4).Resize(Dest.Count - 3).Interior.ColorIndex = xlNone 'RAZ
  n = 0
  For Each c In Source
  If c <> "" Then
  n = n + 1
  If c.Interior.ColorIndex <> xlNone Then
  p = 0
  For j = 4 To Dest.Count
  If Dest(j) <> "" Then
  p = p + 1
  If p = n Then Dest(j).Interior.Color = c.Interior.Color: Exit For
  End If
  Next
  End If
  End If
Next c, i
End Sub
La macro s'exécute quand on active la feuille.

Fichier joint.

A+
je suis dsl je ne comprend pas "activé"la feuille visuel??
 

fred347

XLDnaute Nouveau
Re,

Clic sur l'onglet :rolleyes:

Ma macro du post #7 règle le problème des doublons.

Notez aussi que les couleurs des colonnes de destination sont effacées (RAZ) avant d'être colorées.

A+
je suis dsl mais je ne c'est pas faire :'-) "mètre une macro et l'activé "
 

job75

XLDnaute Barbatruc
Re,

La macro est à placer dans le code de la feuille "visuel" (clic droit sur l'onglet et Visualiser le code).

Ensuite clic sur l'onglet, la macro se déclenche automatiquement.

Voici maintenant une solution meilleure car plus rapide avec l'objet Dictionary :
Code:
Private Sub Worksheet_Activate()
Dim d As Object, i As Byte, Source As Range, Dest As Range, n&, j&
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Dest.Parent.UsedRange.EntireRow)
  If Dest.Count > 3 Then Dest(4).Resize(Dest.Count - 3).Interior.ColorIndex = xlNone 'RAZ
  d.RemoveAll
  n = 0
  For j = 4 To Dest.Count
  If Dest(j) <> "" Then n = n + 1: d(n) = j
  Next j
  n = 0
  For j = 1 To Source.Count
  If Source(j) <> "" Then
  n = n + 1
  If Source(j).Interior.ColorIndex <> xlNone Then _
  If d.exists(n) Then Dest(d(n)).Interior.Color = Source(j).Interior.Color
  End If
Next j, i
End Sub
Edit : je n'utilise plus la variable c (Range), la macro est plus homogène.

Fichier (2).

Bonne soirée.
 

Fichiers joints

Dernière édition:

fred347

XLDnaute Nouveau
bonsoir
je remercie jacky67 et job75 pour votre patience .
sa a marcher, je vais juste crée une petite macro avec un bouton pour tout effacer d'un coup (oui je vient d’apprendre a le faire sur un site lol)
merci a vous !!!!!!!!!!!
 

job75

XLDnaute Barbatruc
Bonjour fred347, le forum,

Il y a plusieurs erreurs dans les colonnes de destination, cette macro les met en évidence :
Code:
Private Sub Worksheet_Activate()
Dim d As Object, i As Byte, Source As Range, Dest As Range, n&, j&, dc&
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Dest.Parent.UsedRange.EntireRow)
  If Dest.Count > 3 Then Dest(4).Resize(Dest.Count - 3).Interior.ColorIndex = xlNone 'RAZ
  d.RemoveAll
  n = 0
  For j = 4 To Dest.Count
  If Dest(j) <> "" Then n = n + 1: d(n) = j
  Next j
  dc = d.Count
  n = 0
  For j = 1 To Source.Count
  If Source(j) <> "" Then
  n = n + 1
  If n > dc Then MsgBox "Nombre de valeurs insuffisant en 'Dest" & i & "' !", 48: GoTo 1
  If Dest(d(n)) <> Source(j) Then _
  MsgBox "Valeur incorrecte en " & Dest(d(n)).Address(0, 0) & " !", 48: GoTo 1
  If Source(j).Interior.ColorIndex <> xlNone Then _
  Dest(d(n)).Interior.Color = Source(j).Interior.Color
  End If
  Next j
  If n < dc Then MsgBox "Valeurs excédentaires en 'Dest" & i & "'..."
1 Next i
End Sub
Fichier (3).

Corrigez vos erreurs pour que la correspondance soit bonne !

Bonne journée.
 

Fichiers joints

Dernière édition:

Jacky67

XLDnaute Accro
Re,

Dans ce fichier (3 bis) j'ai corrigé toutes les erreurs.

A+
Bonjour job75

Bravo pour tes solutions
Les questions que je me pose:
Comment sont saisie les données en feuille "Visuel" ?
A quoi cela sert, si la correspondance aux nombres n'est pas visuel ?
Salutations
JJ
 

job75

XLDnaute Barbatruc
Bonjour Jacky67,

Oui c'est la question que je posais dès le début au post #7.

Même par macro il n'est pas du tout évident de créer la feuille "visuel" avec les bonnes valeurs.

A+
 

job75

XLDnaute Barbatruc
Re,

Bon je suis parvenu à faire les rangements des valeurs dans la feuille "visuel".

Cela devient assez trapu, j'utilise la macro Quick sort pour le tri :
Code:
Private Sub Worksheet_Activate()
Dim i As Byte, a(), n&, ii As Byte, Source As Range, j&, b(), col As Byte, x, k&, Dest As Range, d As Object
Application.ScreenUpdating = False
Range("A4:M" & Rows.Count).Delete xlUp 'RAZ
'---RANGEMENTS---
For i = 1 To 7 Step 6 '2 tableaux de 6 colonnes
  Erase a
  n = 0
  '---liste de toutes les valeurs---
  For ii = i To i + 5
    Set Source = Evaluate(ThisWorkbook.Names("Source" & ii).RefersTo)
    Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
    For j = 1 To Source.Count
      If Source(j) <> "" Then
        n = n + 1
        ReDim Preserve a(1 To n)
        a(n) = Source(j)
      End If
  Next j, ii
  If n = 0 Then GoTo 1
  '---tri croissant et rangement des valeurs---
  tri a, 1, UBound(a)
  ReDim b(1 To n, 1 To 6)
  For ii = i To i + 5
    Set Source = Evaluate(ThisWorkbook.Names("Source" & ii).RefersTo)
    Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
    col = ii - i + 1
    For j = 1 To Source.Count
      x = Source(j)
      If x <> "" Then
        For k = 1 To n
          If x = a(k) And b(k, col) = "" Then b(k, col) = x: Exit For
        Next k
      End If
  Next j, ii
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Dest(4).Resize(n, 6) = b
  '---suppression des lignes vides de chaque tableau---
  For j = n + 3 To 4 Step -1
    If Application.CountA(Dest(j).Resize(, 6)) = 0 Then Dest(j).Resize(, 6).Delete xlUp
1 Next j, i
'---COLORATIONS---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Dest.Parent.UsedRange.EntireRow)
  d.RemoveAll
  n = 0
  For j = 4 To Dest.Count
    If Dest(j) <> "" Then n = n + 1: d(n) = j
  Next j
  n = 0
  For j = 1 To Source.Count
    If Source(j) <> "" Then
      n = n + 1
      If Dest(d(n)) <> Source(j) Then _
        MsgBox "La colonne 'Source" & i & "' n'est pas triée correctement !", 48: Exit For
      If Source(j).Interior.ColorIndex <> xlNone Then _
        Dest(d(n)).Interior.Color = Source(j).Interior.Color
    End If
Next j, i
End Sub

Sub tri(a, gauc, droi)     ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
Il ne peut donc plus y avoir d'erreurs SAUF si les colonnes sources ne sont pas triées correctement.

Nouveau fichier joint.

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Pour terminer, ceci fonctionne même si les colonnes sources ne sont pas triées :
Code:
'---COLORATIONS---
For i = 1 To 12
  Set Source = Evaluate(ThisWorkbook.Names("Source" & i).RefersTo)
  Set Source = Intersect(Source, Source.Parent.UsedRange.EntireRow)
  Set Dest = Evaluate(ThisWorkbook.Names("Dest" & i).RefersTo)
  Set Dest = Intersect(Dest, Me.UsedRange.EntireRow)
  dc = Dest.Count
  For j = 1 To Source.Count
    x = Source(j)
    If x <> "" Then
      If Source(j).Interior.ColorIndex <> xlNone Then
        For k = 4 To dc
          If Dest(k) = x Then If Dest(k).Interior.ColorIndex = xlNone _
            Then Dest(k).Interior.Color = Source(j).Interior.Color: Exit For
        Next k
      End If
    End If
Next j, i
End Sub
Il n'y a plus d'objet Dictionary, cela prend plus de temps, mais aucune erreur n'est maintenant possible.

Fichier (2).

A+
 

Fichiers joints

Dernière édition:

fred347

XLDnaute Nouveau
Bonjour job75

Bravo pour tes solutions
Les questions que je me pose:
Comment sont saisie les données en feuille "Visuel" ?
A quoi cela sert, si la correspondance aux nombres n'est pas visuel ?
Salutations
JJ
bonjour
en fait la page visuel me sert juste a savoir quelle et le meilleur élément a installer (pour mon jeux )

1° dans mon jeux il y a des coche pour savoir ce que je peut acheter
upload_2016-7-25_20-2-13.png
2°c'est la que je transmet mes couleur sur ce que je peut prendre
upload_2016-7-25_20-5-28.png
3°je retourne sur la page "visuel" pour voir quelle est le meilleur a acheter
upload_2016-7-25_20-6-40.png
on vois quand mm mieux que sur des pages comme ca
surtout quand il y en a 43
upload_2016-7-25_20-8-16.png
merci a vous !!
 

Fichiers joints


Haut Bas