VBA - Soucis de PasteSpcial ne concernant que les formats

Version imprimable

1 pièce(s) jointe(s)

Bonjour,

Je développe une petite macro qui automatise la création d'un tableau, au fur et à mesure que j'ajoute des lignes ;

J'ai un optional a (boolean) qui automatique la creation de l'en tête,

Le tout part d'une cellule (haut à gauche).

Voici le 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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Sub CadreWS(c As Range, ws As Worksheet, Optional a As Boolean): Application.ScreenUpdating = False
 
'########################################################
' Cree une tableau automatique
' (borders)
' si a <> nothing la premiere ligne prend le format de c
' NB : peut être mieux avec CurrentRegion
'########################################################
 
Dim lig As Integer
Dim col As Integer
 
Dim rTete As Range  'en tete du tableau
Dim rg As Range     ' range tableau
Dim rg2 As Range    ' range un peu plus grand que le tableau (pour effacement bordures)
Dim lig2 As Integer ' lignes de rg2
Dim col2 As Integer ' col de rg2
 
 
' PART 1 - CURRENTREGION
 
'affectation range de travail
Set rg = c.CurrentRegion
 
'dim du futur tableau
lig = rg.Rows.Count
col = rg.Columns.Count
 
 
' condition d'exit pour si on n'a qu'une ligne
If lig = 1 Then Exit Sub
 
'dim +1 du futur tableau (pour effacement bordures)
lig2 = lig + 1
col2 = col + 1
 
'affectation tableau + 1
Set rg2 = rg.Resize(lig2, col2) ': Debug.Print "Adresse de rg2 : " & rg2.Address(False, False)
 
' PART 2 - GESTION BORDURES
 
With ws
    'condition sortie si juste c en entete (en fait deja verifie avant)
    'If col2 = .Columns.Count + 1 Then Exit Sub
 
    'effacement bordures precedentes
    rg2.Borders.LineStyle = xlLineStyleNone
 
    'mise en forme bordures
    With rg.Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
 
' PART 3 - COLOR ENTETE
    If a = True Then
        Set rTete = rg.Resize(1, col) ': Debug.Print "Adresse de rTete : " & rTete.Address(False, False)
        c.Copy (rTete.PasteSpecial(xlPasteFormats))
 
        Application.CutCopyMode = False
    End If
End With
Application.ScreenUpdating = True
End Sub

Je cherche à faire exactement ceci
J'ai pris l'habitude de faire les CTRL + ALT + V, à la mano ça marche très bien pour choisir "FORMAT".
Mais en VBA, ça semble plus compliqué,
mon code ne fonctionne pas, cela pêche (ou poire !) à cette partie :

Code:

1
2
3
4
5
6
7
PART 3 - COLOR ENTETE
    If a = True Then
        Set rTete = rg.Resize(1, col) ': Debug.Print "Adresse de rTete : " & rTete.Address(False, False)
        c.Copy (rTete.PasteSpecial(xlPasteFormats))
 
        Application.CutCopyMode = False
    End If

Je suis tombé sur de nombreux sujets, par exemple celui-ci Pièce jointe 351732

J'ai essayé avec plusieurs façons de faire, jusqu'à présent ça n'a rien donné !

N'hésitez pas si vous avez des pistes,

Zoubi la team !

Ok, j'ai finalement trouvé !

Voici la façon de gérer le collage d'uniquement le format :

Code:

1
2
3
4
5
6
7
8
9
Sub CopieFormats(cDepart As Range, rgDestination As Range, Optional ws As Worksheet)
 
'applique a rgDestination le format de la plage cDepart
 
cDepart.Copy
rgDestination.PasteSpecial xlPasteFormats
 
Application.CutCopyMode = False
End Sub

Mon 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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
 
Sub CadreWS(c As Range, ws As Worksheet, Optional a As Boolean): Application.ScreenUpdating = False
 
'########################################################
' Cree une tableau automatique
' (borders)
' si a <> nothing la premiere ligne prend le format de c
' NB : peut être mieux avec CurrentRegion
'########################################################
 
Dim lig As Integer
Dim col As Integer
 
Dim actCell As Range ' cellule active au lancement
Dim rTete As Range  'en tete du tableau
Dim rg As Range     ' range tableau
Dim rg2 As Range    ' range un peu plus grand que le tableau (pour effacement bordures)
Dim lig2 As Integer ' lignes de rg2
Dim col2 As Integer ' col de rg2
 
 
' PART 1 - CURRENTREGION
 
'affectation range de travail
Set rg = c.CurrentRegion
 
Set actCell = ActiveCell
 
'dim du futur tableau
lig = rg.Rows.Count
col = rg.Columns.Count
 
 
' condition d'exit pour si on n'a qu'une ligne
If lig = 1 Then Exit Sub
 
'dim +1 du futur tableau (pour effacement bordures)
lig2 = lig + 1
col2 = col + 1
 
'affectation tableau + 1
Set rg2 = rg.Resize(lig2, col2) ': Debug.Print "Adresse de rg2 : " & rg2.Address(False, False)
 
' PART 2 - GESTION BORDURES
 
With ws
    'condition sortie si juste c en entete (en fait deja verifie avant)
    'If col2 = .Columns.Count + 1 Then Exit Sub
 
    'effacement bordures precedentes + coul de fond eventuelle
    rg2.Borders.LineStyle = xlLineStyleNone
    .Cells(lig, col + 1).Interior.Color = vbWhite
 
    'mise en forme bordures
    With rg.Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
 
' PART 3 - COLOR ENTETE
    If a = True Then
        Set rTete = rg.Resize(1, col) ': Debug.Print "Adresse de rTete : " & rTete.Address(False, False)
        c.Copy
        rTete.PasteSpecial xlPasteFormats
 
        Application.CutCopyMode = False
    End If
End With
 
actCell.Activate
 
Application.ScreenUpdating = True
End Sub

16/02/2018, 13h38
halaster08
Bonjour,

Il me semble que le pastespecial s'écrit sur deux lignes:
essaye de remplacer:

Code:

c.Copy (rTete.PasteSpecial(xlPasteFormats))
Code:

1 2 c.Copy rTete.PasteSpecial xlPasteFormats
edit: trop lent, le temps que j'écrive tu avais déjà ta réponse.

Et pourtant, impossible de dire que tu as été lent à réagir !!

Un grand merci,
j'avais déjà manipulé du copy destination:= sur la même ligne, de mémoire ...
Donc je ne voyais pas de logique à ce que ce soit ici différent,

Quoiqu'il en soit j'ai ma réponse, je te remercie :)

Et donc j'ai mis la macro générique, au cas où un autre chercherait un jour, je la remets au cas ou :
Code:

1 2 3 4 5 6 7 8 9 Sub CopieFormats(cDepart As Range, rgDestination As Range, Optional ws As Worksheet) 'applique a rgDestination le format de la plage cDepart cDepart.Copy rgDestination.PasteSpecial xlPasteFormats Application.CutCopyMode = False End Sub
Encore merci ;)

Quand y'en n'a plus, y'en a encore !!

Quand y'en n'a plus, y'en a encore !!

Donc désormais, autre soucis : cette façon d'appliquer le format empêche la sélection de toute plage de cellule (la macro se lance, et la selection d'une plage ne se fait plus)

J'ai tenté de résoudre cela avec l'injection de cette condition, déjà pas si top à mon goût
Code:

1 2 'ne se lance pas si l'on n'a plus d'une cellule selectionnee If Selection.Cells.Count <> 1 Then Exit Sub
Il apparait que même ainsi, un CTRL + A provoquant un dépassement de capacité... Selection.cells.count doit être trop gros pour le plus gros double ? (lignes max x col max, sans doutes...),
Cette méthode ne fonctionne pas.

De plus, la currentRegion prend aussi en compte les bordures, etc ...
Bref, finalement si j'enlève des données, le fond demeure ainsi que les bordures -> ça ne fait pas le boulot demandé.

Je vais abandonner cette méthode, et récupérer les données avec des endXldown, comme j'avais commencé par le faire.
Et pour le format, repasser par un (bête) :
Code:

1 2 3 4 5 6 With rTete .Color = c.Font.Color 'couleur .Name = c.Font.Name 'recuperer la police .Size = c.Font.Size 'taille .Interior.Color = c.Interior.Color End With
Je viens de me remémorer pourquoi je n'utilise jamais CurrentRegion...

Bon.

Je n'arrive pas trop à comprendre pourquoi, mais ça semble désormais bien fonctionner, en F8 (pas à pas) et en F5...

Changements :
- Je récupère et stocke les couleurs de fond / texte de la cellule c, je la réapplique a la fin,
-je passe par une gestion des erreurs... Qui exit sub pour éviter le dépassement de capacité. Pas mégatop, y a t-il mieux ?

EDIT : finalement j'ai mis en commentaire cette partie, je n'arrive plus trop à y réfléchir mais ça fonctionne sans ...
j'ai un peu du mal quand même.
J'ai l'impression que le raccourcis clavier CTRL + * qui donne la currentRegion, ne donne pas exactement la currentRegion VBA..
Peut être des propriétés que je n'ai pas pris le temps d'étudier ?!

Bref.

Citation:

Le code semble fonctionnel, n'hésitez pas à le récupérer,
Il créer un tableau avec la currentRegion à partir de la cellule désignée (et optionnellement, l'entête du tableau prend la mise en forme de ladite cellule)

Code:

1
2
3
4
5
'ne se lance pas si l'on n'a plus d'une cellule selectionnee
'gestion de l'erreur de depassement de capacite
On Error Resume Next
    If Selection.Cells.Count <> 1 Then Exit Sub
On Error GoTo 0

Voici le code total :

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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
Sub CadreWS(c As Range, ws As Worksheet, Optional a As Boolean): Application.ScreenUpdating = False
 
'########################################################
' Cree une tableau automatique
' (borders)
' si a <> nothing la premiere ligne prend le format de c
' NB : peut être mieux avec CurrentRegion
'########################################################
 
Dim lig As Integer
Dim col As Integer
 
Dim rTete As Range  'en tete du tableau
Dim rg As Range     ' range tableau
Dim rg2 As Range    ' range un peu plus grand que le tableau (pour effacement bordures)
Dim lig2 As Integer ' lignes de rg2
Dim col2 As Integer ' col de rg2
Dim actCell As Range ' cellule(s) active(s) au lancement
 
Dim couleurFond As Integer ' pour recuperer la couleur de la cellule c
Dim couleurTxt As Integer ' pour recuperer la couleur de la cellule c
 
'ne se lance pas si l'on n'a plus d'une cellule selectionnee
'gestion de l'erreur de depassement de capacite
'On Error Resume Next
'    If Selection.Cells.Count <> 1 Then Exit Sub
'On Error GoTo 0
 
' PART 1 - CURRENTREGION
 
'affectation range de travail
Set rg = c.CurrentRegion ': Debug.Print "adresse du range rg (a mettre en tableau : " _
& vbCrLf & rg.Address(False, False)
 
couleurFond = c.Interior.ColorIndex
couleurTxt = c.Font.ColorIndex
 
'dim du futur tableau
lig = rg.Rows.Count
col = rg.Columns.Count
 
 
' condition d'exit pour si on n'a qu'une ligne
'If lig = 1 Then Exit Sub
 
'dim +1 du futur tableau (pour effacement bordures)
lig2 = lig + 1
col2 = col + 1
 
'affectation tableau + 1
Set rg2 = rg.Resize(lig2, col2) ': Debug.Print "Adresse de rg2 : " & vbCrLf & rg2.Address(False, False)
 
' PART 2 - GESTION BORDURES
 
With ws
    'condition sortie si juste c en entete (en fait deja verifie avant)
    'If col2 = .Columns.Count + 1 Then Exit Sub
 
    'effacement bordures precedentes + coul de fond eventuelle
    rg2.Borders.LineStyle = xlLineStyleNone
    rg2.Interior.ColorIndex = xlColorIndexNone
 
    'mise en forme bordures
    With rg.Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
 
' PART 3 - COLOR ENTETE
    If a = True Then
        Set rTete = rg.Resize(1, col)
        With rTete
            .Font.ColorIndex = couleurTxt   'couleur
            .Font.Name = c.Font.Name     'recuperer la police
            .Font.Size = c.Font.Size     'taille
            .Interior.ColorIndex = couleurFond
        End With
        Application.CutCopyMode = False
    End If
End With
 
Application.ScreenUpdating = True
End Sub