rapatriement format cellule

Version imprimable

Bonjour,

J'ai cette macro qui fonctionne bien.
Elle me permet de récupérer des lignes d'un tableau dans l'onglet "Source" avec la date de l'année en cours et de les mettre dans l'onglet "Tr2".
Le seul soucis c'est que certaines cellules ont des formats spécifiques que j'aimerai également rapatrié, mais je n'arrive pas à le faire.
Quelqu'un pourrait m'aider svp?
Merci d'avance !

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
Sub A_graph()
 
Dim CS As Workbook, CD As Workbook 'déclare les variables CS (Classeur Source) et CD (Classeur Destination)
Dim OS As Worksheet, Tr2 As Worksheet 'déclare les variable OS (Onglet Source) et Tr2 (Onglet Destination)
 
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OS = CD.Worksheets("Source") 'définit l'onglet source OS
Set Tr2 = CD.Worksheets("Tr2") 'définit l'onglet destination OD
 
Tr2.Select
Tr2.Range("A2:Z400").Clear 'efface d'éventuelles anciennes données
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
 
For I = 4 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la quatrieme)
    A = Year(TV(I, 1)) 'définit l'année A de la donnée ligne I colonne 1 de TV
    If A = Year(Date) Then   'condition : si l'année A correspond à la valeur de A1
        LI = Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI (première ligne vide de la colonne A)
        Cells(LI, "A") = TV(I, 1) 
        Cells(LI, "B") = TV(I, 38) 
        Cells(LI, "C") = TV(I, 41) 
        Cells(LI, "D") = TV(I, 73) 
        Cells(LI, "E") = TV(I, 76) 
    End If 'fin de la condition
Next I 'prochaine ligne de a boucle
 
End Sub

Bonjour,

Le plus simple est de passer par une copie. L'exportation de format d'une cellule à l'autre sans passer par le presse-papier est en effet pénible.
Vous pourriez par exemple créer une Sub dédiée à la copie :

Code:

1
2
3
4
5
6
Sub CopyCellWithFormat(Src as Range, Dest as Range)
    Src.Copy
    Dest.PasteSpecial xlPasteValues
    Dest.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End Sub

Il est ensuite aisé de modifier votre précédent code :

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
Sub A_graph()
 
Dim CS As Workbook, CD As Workbook 'déclare les variables CS (Classeur Source) et CD (Classeur Destination)
Dim OS As Worksheet, Tr2 As Worksheet 'déclare les variable OS (Onglet Source) et Tr2 (Onglet Destination)
 
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OS = CD.Worksheets("Source") 'définit l'onglet source OS
Set Tr2 = CD.Worksheets("Tr2") 'définit l'onglet destination OD
 
Tr2.Select
Tr2.Range("A2:Z400").Clear 'efface d'éventuelles anciennes données
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
 
For I = 4 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la quatrieme)
    A = Year(TV(I, 1)) 'définit l'année A de la donnée ligne I colonne 1 de TV
    If A = Year(Date) Then   'condition : si l'année A correspond à la valeur de A1
        LI = Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI (première ligne vide de la colonne A)
        CopyCellWithFormat TV(I, 1), Cells(LI, "A")
        CopyCellWithFormat TV(I, 38), Cells(LI, "B")
        CopyCellWithFormat TV(I, 41), Cells(LI, "C")
        CopyCellWithFormat TV(I, 73), Cells(LI, "D")
        CopyCellWithFormat TV(I, 76), Cells(LI, "E")
    End If 'fin de la condition
Next I 'prochaine ligne de a boucle
 
End Sub

Notez que le test :

Code:

If A = Year(Date) Then

ne vérifie pas si l'année A est identique à celle de la cellule A1. Il vérifie plutôt que l'année A est identique à l'année en cours.

Cdt

07/08/2020, 13h25
yperrin55

1 pièce(s) jointe(s)

Bonjour ,
Merci de votre réponse rapide.
Pour le test :

Code:

If A = Year(Date) Then

J'ai oublié de modifier le commentaire correspondant... Mais c'est bien ce test que je souhaite. :)

En ce qui concerne votre solution, j'ai un message d'erreur qui me dit :

Pièce jointe 576843

Le TV de la première ligne de ma boucle se sélectionne également tout seul.

Arfff...

Un problème de type de données.
La variable TV était de type 'Variant', ce qui posait problème.
En la redéfinissant en tant que 'Range', le problème devrait être résolu :

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
Sub A_graph()
 
    Dim CS As Workbook, CD As Workbook 'déclare les variables CS (Classeur Source) et CD (Classeur Destination)
    Dim OS As Worksheet, Tr2 As Worksheet 'déclare les variable OS (Onglet Source) et Tr2 (Onglet Destination)
    Dim I As Long, A As Long, LI As Long, TV As Range
     
    Set OS = ThisWorkbook.Worksheets(1)
    Set Tr2 = ThisWorkbook.Worksheets(2)
     
    Tr2.Select
    Tr2.Range("A2:Z400").Clear 'efface d'éventuelles anciennes données
    Set TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
     
    For I = 4 To TV.Rows.Count 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la quatrieme)
        A = Year(TV(I, 1)) 'définit l'année A de la donnée ligne I colonne 1 de TV
        If A = Year(Date) Then   'condition : si l'année A correspond à la valeur de A1
            LI = Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI (première ligne vide de la colonne A)
            CopyCellWithFormat TV(I, 1), Cells(LI, "A")
            CopyCellWithFormat TV(I, 38), Cells(LI, "B")
            CopyCellWithFormat TV(I, 41), Cells(LI, "C")
            CopyCellWithFormat TV(I, 73), Cells(LI, "D")
            CopyCellWithFormat TV(I, 76), Cells(LI, "E")
        End If 'fin de la condition
    Next I 'prochaine ligne de a boucle
 
End Sub

Cdt

10/08/2020, 10h18
yperrin55

Merci de votre aide, ça fonctionne très bien ! :D:D