Recopier Donnee Avec La Meme Couleur De Police

[MikeBelgique]

Bonjour tout le monde, je souhaiterais un petit coup de pouce, je joint le fichier avec explication, merci de votre aide

[BOISGONTIER]

Bonjour,

Voir PJ

JB

[MikeBelgique]

Merci pour ta formule qui est plus simple que celle que j'avais mais mon réel problème se situe sur la feuille 2, désolé j'aurais du le stipuler

[BOISGONTIER]

Voir PJ

Private Sub Worksheet_Activate()
 For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 23)
    a = Split(Mid(c.Formula, 2), "!")
    Sheets(a(0)).Range(a(1)).Copy
    c.PasteSpecial Paste:=xlPasteFormats
  Next c
End Sub

JB

[MikeBelgique]

Merci à toi Boisgontier, cela marche très bien mais peux ton limiter à recopier uniquement la couleur de police sans prendre en compte la couleur de font de cellule ni format, je sais je suis difficile et compliqué mais c'est important pour la bonne suite

[BOISGONTIER]

Private Sub Worksheet_Activate()
 For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 23)
    a = Split(Mid(c.Formula, 2), "!")
    c.Font.ColorIndex = Sheets(a(0)).Range(a(1)).Font.ColorIndex
  Next c
End Sub

JB

[MikeBelgique]

Bonjour, désolé boisgontier de répondre si tard mais je n'ai pas eu le temps de m'occuper de tout cela. Merci à toi, mais je n'arrive pas à le faire fonctionner sur mon fichier, ligne erreur d'éxécution 9
c.Font.ColorIndex = Sheets(a(0)).Range(a(1)).Font.ColorIndex se met en jaune (a(0)).Range(a(1)) l'indice n'appartient pas à la sélection. J'ai beau chercher, tripatouiller, tester je n'arrive pas à la solution finale.

[MikeBelgique]

Oups je reviens à la charge, pour mon problème, qui peut m'aider, doit on peut etre cibler la plage de reference, du fait que sur mon fichier il existe d'autre donnees sur la page? merci à vous de m'éclairer

[BOISGONTIER]

Bonjour,

Private Sub Worksheet_Activate()
 Set champ = Range("B7:U8")
 For Each c In champ.SpecialCells(xlCellTypeFormulas, 23)
    a = Split(Mid(c.Formula, 2), "!")
    c.Font.ColorIndex = Sheets(a(0)).Range(a(1)).Font.ColorIndex
 Next c
End Sub

JB

[MikeBelgique]

Grand grand merci BOISGONTIER, pour la rapidité de ta réponse et je confirme que cela fonctionne nickel, mille merci.:

[MikeBelgique]

J'aurais souhaiter un petit plus ; le calcul du nbr de cellule écrite en noir voir fichier joint page 2

[BOISGONTIER]

Voir PJ

Function compteCouleurTexte(champ, couleur)
  Application.Volatile
  n = 0
  For Each c In champ
    If c.Font.ColorIndex = couleur Then n = n + 1
  Next c
  compteCouleurTexte = n
End Function

JB

[MikeBelgique]

ah j'avais pas fait attention au petit calculate, et je cherchais pourquoi il ne calculait pas automatiquement sur mon fichier, et voilà c parfait maintenant, comme depuis le début toujours au top, merci BOISGONTIER, trop fort!!!