Copier / coller avec PasteSpecial impossible

**pimpom81** · 14/08/2012, 17h05

Bonjour à tous

Je sèche sur un code pour copier / coller les valeurs (PasteSpecial)

Lorsque j'exécute ce code en test il bug car "impossible de lire la propriété pastespecial de la classe range".

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub Afficher_Click()
Dim LastLig As Long, NewLig As Long, i As Long, DerLig As Long
Dim Année As Integer, Avct As String
Dim c As Range, d As Range, e As Range
 
 
'Ouvrir le fichier "Archives observations"
Workbooks.Open Filename:="E:\Rapports d'audits EHS\Archives observations.xlsm"
 
Application.ScreenUpdating = False
 
Année = CbB_Archivage.Value
Avct = "100%"
 
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
    If Année = CbB_Archivage.Value Then
    NewLig = Cells(1 & Rows.Count).End(xlUp).Row
        With Workbooks("HRQF898-01").Worksheets("Recueil données")
        'Copie des lignes à sélectionner dans cellules de destinations
            LastLig = .Cells(.Rows.Count, 1)End(xlUp).Row
            If LastLig >= 171 Then
                For i = 171 To LastLig
                    Set c = .Range("A" & i & ":AV" & i).Find(Année, LookIn:=xlValues, Lookat:=xlWhole)
                    If Not c Is Nothing Then
                        c.EntireRow.Cut Workbooks("Archives observations").Worksheets("Archive des données").Range("A" & NewLig).PasteSpecial(Paste:=xlPasteValues)
                        Set c = Nothing
                        NewLig = NewLig + 1
                    End If
                Next i
            End If
        End With
    NewLig = 0
    End If

Quelqu'un a t'il une idée?

Cordialement

**Theze** · 14/08/2012, 17h24

Bonjour,

As tu contrôlé la valeur de "NewLig" avant la ligne incriminée ?

Hervé.

**mercatog** · 14/08/2012, 17h26

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'Ouvrir le fichier "Archives observations"
Application.ScreenUpdating = False
Set Wbk = Workbooks.Open("E:\Rapports d'audits EHS\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
Set Ws = Wbk.Worksheets("Archive des données")
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLig = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row + 1
    With ThisWorkbook.Worksheets("Recueil données")
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLig >= 171 Then
            For i = 171 To LastLig
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    c.EntireRow.Copy
                    Ws.Range("A" & NewLig).PasteSpecial Paste:=xlPasteValues
                    Set c = Nothing
                    NewLig = NewLig + 1
                End If
            Next i
        End If
    End With
End If
Set Ws = Nothing

**pimpom81** · 15/08/2012, 12h17

J'ai oublié de préciser l'action de copier coller est sur deux fichiers différents, un qui s'appelle "HRQF898-01" et l'autre "Archive observations"

Mercatog est ce que la ligne suivante n'est pas a améliorer:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    With ThisWorkbook.Worksheets("Recueil données")

Par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With Workbooks("HRQF898-01").Worksheets("Recueil données")

Theze : J'ai mis un contrôle sur la valeur "Newlig"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Newlig = 0

Merci à vous deux

**Theze** · 16/08/2012, 08h23

Bonjour,

Si tu mets "NewLig" à 0 tu as une erreur car il n'existe pas de cellule A0 !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
c.EntireRow.Cut Workbooks("Archives observations").Worksheets("Archive des données").Range("A" & NewLig).PasteSpecial(Paste:=xlPasteValues)

Hervé.

**pimpom81** · 16/08/2012, 15h05

Theze merci pour ton commentaire, en fait je me suis inspiré du code de mercatog.

Ca marche sauf que je change la fonction ".copy" en ".cut" j'ai un plantage

En ".cut", la ligne se copie sur le fichier mais comme il boucle sur "c.", à la deuxième boucle il affiche le message d'erreur : "impossible de lire la propriété pastespecial de la classe range".

Une petite idée la dessus sur l'origine du problème.

cordialement

**mercatog** · 16/08/2012, 15h20

Est ce que manuellement tu peux faire Couper -- Collage Spécial????

**pimpom81** · 16/08/2012, 15h43

Salut mercatog

Je peux pas faire de couper collage spécial. Je ne peux que faire couper coller
Macro d'essai

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
    Selection.Cut
    Windows("Archives observations.xlsm").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("HRQF898-01.xlsm").Activate

Les autres accès au fonction coller sont grisés.

**mercatog** · 16/08/2012, 15h47

Si tu ne peux pas le faire manuellement, par macro tu ne peux pas.
D'où, faudra procéder autrement
Copier- Collage Spécial - Suppression de la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'Ouvrir le fichier "Archives observations"
Application.ScreenUpdating = False
Set Wbk = Workbooks.Open("E:\Rapports d'audits EHS\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
Set Ws = Wbk.Worksheets("Archive des données")
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLig = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row + 1
    With ThisWorkbook.Worksheets("Recueil données")
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLig >= 171 Then
            For i = 171 To LastLig
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Copier
                    c.EntireRow.Copy
                    'Collage spécial
                    Ws.Range("A" & NewLig).PasteSpecial Paste:=xlPasteValues
                    'Suppression
                    c.EntireRow.Delete
                    Set c = Nothing
                    NewLig = NewLig + 1
                End If
            Next i
        End If
    End With
End If
Set Ws = Nothing

**pimpom81** · 16/08/2012, 15h56

Merci mercatog, je l'avais anticipé, de plus ça m'allège considérablement le code.

Par contre j'ai d'autre ligne dans ce code copiant/collant d'autres valeurs sources.
En m'aidant de ton code et y faisant quelques peties modif la macro s'exécute sans bug sauf que les-dites valeurs ne se copient pas sur le fichier de destination.

Je te met le code pour que tu y regardes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
Private Sub Afficher_Click()
Dim LastLig As Long, NewLig As Long, i As Long, DerLig As Long
Dim Année As Integer, Avct As String
Dim c As Range, d As Range, e As Range
 
 
'Ouvrir le fichier "Archives observations"
Application.ScreenUpdating = False
Set Wbk = Workbooks.Open("E:\AFS\Audit EHS\Vba\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
Set Ws1 = Wbk.Worksheets("Archive des données")
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLig = Ws1.Cells(Ws1.Rows.Count, 1).End(xlUp).Row + 1
    With Workbooks("HRQF898-01").Worksheets("Recueil données")
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLig >= 171 Then
            For i = 171 To LastLig
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    c.EntireRow.Copy
                    Ws1.Range("A" & NewLig).PasteSpecial Paste:=xlPasteValues
                    c.EntireRow.Delete
                    Set c = Nothing
                    NewLig = NewLig + 1
                End If
            Next i
        End If
    End With
End If
Set Ws1 = Nothing
 
Set Ws2 = Wbk.Worksheets("Archive des Actions Soldées")
NewLig = 1
'Extraction des lignes = à l'année passée et = à 100%, de "Rapport"  vers fichier archivage
    If Année = CbB_Archivage.Value Then
    NewLig = Ws2.Cells(Ws2.Rows.Count, 1).End(xlUp).Row + 1
        With ThisWorkbook.Worksheets("Rapport")
        DerLig = Range("F" & .Rows.Count).End(xlUp).Row
        'Sélection de toutes les données dans les filtres "gpe de section" et "avancement"
            .Range("$A$26:$Q$" & DerLig).AutoFilter Field:=4   '"gpe de section"
            .Range("$A$26:$Q$" & DerLig).AutoFilter Field:=6   '"Opé / Poste"
            .Range("$A$26:$Q$" & DerLig).AutoFilter Field:=15  '"avancement"
        'Tri par ordre croissant de la colonne "Avct"
            .AutoFilter.Sort.SortFields.Clear
            .AutoFilter.Sort.SortFields.Add Key:= _
                Range("O26" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
                :=xlSortNormal
                With .AutoFilter.Sort
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
        'Copie des lignes à sélectionner dans cellules de destinations
            LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
            If LastLig >= 27 Then
                For i = 27 To LastLig
                    Set d = .Range("A" & i & ":Q" & i).Find(Avct, LookIn:=xlValues, Lookat:=xlWhole)
                    If Not d Is Nothing Then
                        d.EntireRow.Copy
                        Ws2.Range("A" & NewLig).PasteSpecial Paste:=xlPasteValues
                        d.EntireRow.Delete
Set d = Nothing
                        NewLig = NewLig + 1
                    End If
                Next i
            End If
        End With
    End If
Set Ws2 = Nothing
 
NewLig = 1
'Copie du contenu de la cellule "Y47:Z47" du "Suivi mensuel"  vers fichier archivage
    NewLig = Range("F" & Rows.Count).End(xlUp).Row + 1
        Workbooks("Archives observations").Worksheets("Liste").Range("F" & NewLig).Value = Workbooks("HRQF898-01").Worksheets("Rapport").Range("Y47:Z47")
                NewLig = NewLig + 1
 
 
'Rafraichissement des filtres "Rapport"
        With Workbooks("HRQF898-01").Worksheets("Rapport")
        DerLig = Range("E" & .Rows.Count).End(xlUp).Row
            .AutoFilter.Sort.SortFields.Clear
            .AutoFilter.Sort.SortFields.Add Key:= _
                Range("A26" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
                :=xlSortNormal
            With .AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
'Rafraichissement des filtres "Recueil données"
        With Workbooks("HRQF898-01").Worksheets("Recueil données")
        DerLig = Range("A" & .Rows.Count).End(xlUp).Row
            .AutoFilter.Sort.SortFields.Clear
            .AutoFilter.Sort.SortFields.Add _
                Key:=Range("A1" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, _
                DataOption:=xlSortNormal
            With .AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
 
Application.ScreenUpdating = True
 
'With Workbooks("Archives observations")
'    .Save
'    .Close
'End With
 
Unload Me
 
End Sub

Merci par avance

**pimpom81** · 17/08/2012, 11h31

J'ai modifié le code de copie, sauf que lorsque j'ai plusieurs lignes, il en copie u1 sur 2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Afficher_Click()
Dim LastLigS1 As Long, LastLigS2 As Long, NewLigC1 As Long, NewLigC2 As Long, i As Long, DerLig As Long
Dim Année As Integer, Avct As String
Dim c As Range, d As Range, e As Range, plage As Range
 
'Ouvrir le fichier "Archives observations"
Application.ScreenUpdating = False
Set WbkC = Workbooks.Open("E:\AFS\Audit EHS\Vba\Archives observations.xlsm")
Année = CbB_Archivage.Value
Avct = "100%"
Set WsC1 = WbkC.Worksheets("Archive des données")                   '1ère feuille cible
Set WsC2 = WbkC.Worksheets("Archive des Actions Soldées")           '2ème feuille cible
Set WsS1 = Workbooks("HRQF898-01").Worksheets("Recueil données")    '1ère feuille source
Set WsS2 = Workbooks("HRQF898-01").Worksheets("Rapport")            '2ème feuille source
 
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
    NewLigC1 = WsC1.Cells(WsC1.Rows.Count, 1).End(xlUp).Row + 1
    With WsS1
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLigS1 = WsS1.Cells(WsS1.Rows.Count, 1).End(xlUp).Row
        If LastLigS1 >= 171 Then
            For i = 171 To LastLigS1
                Set c = WsS1.Range("A" & i & ":AV" & i).Find(Année, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    c.EntireRow.Copy
                    WsC1.Range("A" & NewLigC1).PasteSpecial Paste:=xlPasteValues
                    c.EntireRow.Delete
                    Set c = Nothing
                    NewLigC1 = NewLigC1 + 1
                End If
            Next i
        End If
    End With
Set WsC1 = Nothing

Mon problème en explicant tout:
J'ai 4 lignes, la première est 01/01/13, 01/02/13, 01/03/13 et la dernière est 01/04/13.
Le résultat de la Macro de copie se fait sur les lignes correspondant au date 01/01/13 et 01/03/13 et celles correspondant aux dates 01/02/13 et 01/04/13 restent sur le fichier source.

Quelqu'un peut il m'expliquer?

cordialement

**pimpom81** · 20/08/2012, 16h11

La solution a enfin été trouvée. La suite de cette discussion se trouve dans le forum "Suppression d'une ligne sur deux"

Merci à Mercatog, Theze et Jpcheck pour leur collaboration.

Copier / coller avec PasteSpecial impossible [XL-2007]

Macros et VBA Excel

Discussions similaires

Partager

Partager