XL 2019 Copier/Coller valeur + couleur d'un classeur à un autre

[Lindsay_RBD]

Bonjour à tous,

Au vue du titre, ma demande peut paraître basique, mais pas du tout ! J'ai réalisé quelques macros grâce à l'autoformation et doc grâce à énormément de forum comme celui-ci. Mais je bloque sur l'un de mes fichiers ... Voici mon souhait :

J'ai un classeur Excel "Classeur 1" dans lequel je renseigne des lots matières, la date de réception du certificat matière et le prélèvement de la matière.
Si je ne possède ni le certificat matière, ni le prélèvement matière, le lots est rouge. Si j'ai le certificat mais pas le prélèvement, le lot est orange. Si j'ai les deux, le lot est vert.
Donc jusque là tout va bien car ce sont des mises en forme conditionnelle.

Les 11 derniers lots inscrits sont copier et coller dans le "Classeur 2" suivant la référence de la matière.
Pas de soucis non plus de ce côté avec la macro. La plage est donc :

Range("C9").End(xlDown).Offset(0, 0).Select
Range(ActiveCell(), ActiveCell.Offset(-10, 0)).Copy

Par contre, étant donné que les couleurs sont déterminées par les mises en forme conditionnelle soit :
- je copie les mises en forme conditionnelles, mais qui ne fonctionnent plus dans le Classeur2
- Soit je copie que les valeurs ...

Auriez-vous une solution ?

Voici quelques pistes étudiées :
- Relevé les codes couleurs des MFC pour ensuite les convertir en RVB et les appliquer dans le second classeur. Mais je n'y arrive pas

Sub CoulMFC()
Dim Lig As Long, Cel As Range
Dim Cpt As Long, NbCond As Long, Res As String


For Lig = 1 To Range("C9:C19").Rows.Count
    Res = 0
    Set Cel = Range("C9:C19").Cells(Lig)
    NbCond = Cel.FormatConditions.Count
    For Cpt = 1 To NbCond
        If Cel.DisplayFormat.Interior.Color = Cel.FormatConditions(Cpt).Interior.Color Then
            Res = Cel.FormatConditions(Cpt).Interior.Color
            Exit For
        End If
    Next Cpt
    Cel.Offset(0, 5).Value = Res
Next Lig
End Sub

- Utiliser la fonction Interior.Color mais comme les couleurs à copier sont dans une page variable, je n'arrive pas à appliquer la boucle For ...

Public Sub MAJ()


Dim iLig As Integer
Dim MaPlage As Range
Dim der_ligne As Long, pre_ligne As Integer

der_ligne = Range("C9").End(xlDown).Offset(0, 0).Select
pre_ligne = Range(der_ligne, ActiveCell.Offset(-10, 0))


Set MaPlage = Range(Cells(pre_ligne), Cells(der_ligne))

    For iLig = pre_ligne To der_ligne
        Range("H" & iLig).Interior.Color = Range("C" & iLig).DisplayFormat.Interior.Color
    Next iLig
End Sub

Merci à tous par avance pour votre aide !

 

[Etoto]

Bonjour ou re,

Si tu transformes ton tableau en outil tableau Excel, tu pourras le copier et le placer dans un autre fichier avec les MFC.

EDIT : J'ai vu la destination cela va être compliqué.

 

[Lindsay_RBD]

Bonjour ou re,

Si tu transformes ton tableau en outil tableau Excel, tu pourras le copier et le placer dans un autre fichier avec les MFC.

EDIT : J'ai vu la destination cela va être compliqué.

Oui effectivement car les MFC ne fonctionneront pas dans le tableau dans lequel je veux effectuer le collage. C’est pour cela que je voulais convertir le code couleur MFC en code couleur RVB : pour ensuite pouvoir l’attribuer au cellule correspondante

 

[Etoto]

Alors désolé c'est au dessus de mon niveau.

En espérant que tu aies une solution.

Cordialement

 

[Lindsay_RBD]

Alors désolé c'est au dessus de mon niveau.

En espérant que tu aies une solution.

Cordialement

Merci quand même d’y avoir regardé !

 

[Robert]

Bonjour le fil, bonjour le forum,

Peut-être comme ça :

Sub DerniersLots()
Dim CS As Workbook 'déclare la variale CS (Classeur Source)
Dim OS As Worksheet 'déclare la variale OS (Onglet Source)
Dim CD As Workbook 'déclare la variale CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variale DO (Onglet Destination)
Dim PL As Range 'déclare la variale PL (PLage)
Dim R As Range 'déclare la variale R (Recherche)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = Workbooks("Classeur1.xlsm") 'définit le classeur source CS
Set OS = CS.Worksheets("SPC-Tab") 'définit l'onglet source OS
Set CD = Workbooks("Classeur2.xlsm") 'définit le classeur destination CD
Set OD = CD.Worksheets("Suivi des lots") 'définit l'onglet destination OD
Set R = OD.Cells.Find(what:="10001807", LookIn:=xlValues, LookAt:=xlWhole).Offset(3, 0) 'définit la recherche R
Set PL = OS.Range("C9").End(xlDown).Offset(-10, 0).Resize(11, 1) 'définit la plage PL
PL.Copy R 'copie la plage PL dans R
For Each CEL In PL 'boucle sur toutes les celluole de la plage  PL
    R.FormatConditions.Delete 'supprime la mise en forme conditionnelle
    R.Interior.Color = CEL.DisplayFormat.Interior.Color 'récupère la couleur de la cellule CEL
    Set R = R.Offset(1, 0) 're'définit R
Next CEL 'prochaine cellule de la plage
End Sub

 

[Lindsay_RBD]

Bonjour le fil, bonjour le forum,

Peut-être comme ça :

Sub DerniersLots()
Dim CS As Workbook 'déclare la variale CS (Classeur Source)
Dim OS As Worksheet 'déclare la variale OS (Onglet Source)
Dim CD As Workbook 'déclare la variale CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variale DO (Onglet Destination)
Dim PL As Range 'déclare la variale PL (PLage)
Dim R As Range 'déclare la variale R (Recherche)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = Workbooks("Classeur1.xlsm") 'définit le classeur source CS
Set OS = CS.Worksheets("SPC-Tab") 'définit l'onglet source OS
Set CD = Workbooks("Classeur2.xlsm") 'définit le classeur destination CD
Set OD = CD.Worksheets("Suivi des lots") 'définit l'onglet destination OD
Set R = OD.Cells.Find(what:="10001807", LookIn:=xlValues, LookAt:=xlWhole).Offset(3, 0) 'définit la recherche R
Set PL = OS.Range("C9").End(xlDown).Offset(-10, 0).Resize(11, 1) 'définit la plage PL
PL.Copy R 'copie la plage PL dans R
For Each CEL In PL 'boucle sur toutes les celluole de la plage  PL
    R.FormatConditions.Delete 'supprime la mise en forme conditionnelle
    R.Interior.Color = CEL.DisplayFormat.Interior.Color 'récupère la couleur de la cellule CEL
    Set R = R.Offset(1, 0) 're'définit R
Next CEL 'prochaine cellule de la plage
End Sub

Et bien franchement, je te tire mon chapeau car ça marche super bien !
Un grand merci pour ta réactivité et ton aide sur ce sujet !

 

[Etoto]

Re,

Merci @Robert

Bon WE à vous deux.