Erreur 1004 la methode activate de la classe range

Bonjour le forum

sur ce fichier j'ai ce code d'erreur (1004) qui je n'arrive pas à débugger :

il s'agit de copier une valeur et de la coller sur une autre feuille au sein d'un for ... next.

je suis obliger de rajouter cette opération car le listindex dont j'ai besoin n'est plus le bon puisque j'ai utilisé un additem pour créer une seconde liste.

Je souhaiterai donc pouvoir copier les valeurs de cette liste créée avec un additem pour pouvoir les exploiter par la suite.

Le bug a lieu au moment de sélectionner la cellule de départ sur une autre feuille.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Sheets("Classement").Unprotect Password:="xxx"
'peind en rouge activecell
If Not Application.Intersect(Target, Range("E3:E42")) Is Nothing Then
Range("E3:E42").Interior.Color = RGB(90, 90, 90)
ActiveCell.Interior.Color = RGB(255, 0, 0)
End If

'peind en vert les x au dessus et au dessous
Z = ActiveCell.Row
x = Sheets("Barème").Range("C10").Value
y = -x

'si le joueur sélectionné n'a pas x adversaire au dessus de lui
If Not Application.Intersect(Target, Range("E3:E42")) Is Nothing Then
If Z < x + 3 Then
For K = 1 To Z - 3
Cells(2 + K, "E").Interior.Color = RGB(0, 176, 80)
'copie la liste
Cells(2 + K, "E").Copy
Sheets("Liste").Activate
Cells(1, 2).End(xlDown).Offset(1, 0).Activate
Selection.Paste
Sheets("Classement").Activate
'copie le rang
Cells(2 + K, "B").Copy
Sheets("Liste").Activate
Cells(1, 1).End(xlDown).Offset(1, 0).Activate
Selection.Paste
Sheets("Classement").Activate

Next K

For I = 1 To x
Cells(Z + I, "E").Interior.Color = RGB(0, 176, 80)
Next I

End If
End If

'si le joueur sélectionné a x adversaire au dessus de lui
If Not Application.Intersect(Target, Range("E3:E42")) Is Nothing Then
If Z >= x + 3 Then
For I = 1 To x
Cells(Z + I, "E").Interior.Color = RGB(0, 176, 80)
Next I

For J = y To -1
Cells(Z + J, "E").Interior.Color = RGB(0, 176, 80)
Next J

End If
End If

Sheets("Classement").Protect Password:="xxx"

End Sub

Merci si quelqu'un voit une solution.

A bientôt.

bonjour,

Activate et Select sont des résidus d'utilisation de l'enregistreur de macro : Ils doivent être banni de votre code !

A tester :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count = 1 Then 'ne fonctionne que sur sélection unique
   Sheets("Classement").Unprotect Password:="xxx"
   'peind en rouge activecell
   If Not Application.Intersect(Target, Range("E3:E42")) Is Nothing Then
      Range("E3:E42").Interior.Color = RGB(90, 90, 90)
      Target.Interior.Color = RGB(255, 0, 0)
   End If
   'peind en vert les x au dessus et au dessous
   Z = Target.Row
   x = Sheets("Barème").Range("C10").Value
   y = -x

   If Z < x + 3 Then 'si le joueur sélectionné n'a pas x adversaire au dessus de lui
      For K = 1 To Z - 3
         Cells(2 + K, "E").Interior.Color = RGB(0, 176, 80)
         'copie la liste
         Cells(2 + K, "E").Copy Sheets("Liste").Cells(1, 2).End(xlDown).Offset(1, 0)
         Cells(2 + K, "B").Copy Sheets("Liste").Cells(1, 1).End(xlDown).Offset(1, 0)
      Next K
      For I = 1 To x
         Cells(Z + I, "E").Interior.Color = RGB(0, 176, 80)
      Next I
   Else 'si le joueur sélectionné a x adversaire au dessus de lui
      For I = 1 To x
         Cells(Z + I, "E").Interior.Color = RGB(0, 176, 80)
      Next I
      For J = y To -1
         Cells(Z + J, "E").Interior.Color = RGB(0, 176, 80)
      Next J
   End If
   Sheets("Classement").Protect Password:="xxx"
End If
End Sub

A+

Bonjour

merci de l’intérêt pour mon problème.

J'ai remplacé mon code par le votre mais j'obtiens toujours une erreur 1004 : erreur définit par l'application ou l'objet.

Et toujours la même ligne est en cause.

Cells(2 + K, "E").Copy Sheets("Liste").Cells(1, 2).End(xlDown).Offset(1, 0) 

Une autre idée ?

Moi je cale ...

Merci

Parce que ta feuille "Liste" est vide...

A+

Merci de vous intéresser à ce post

J'ai mis une ligne de titre sur les colonnes concernées :

tjs la même erreur !

Merci

JB

[Edit: ma proposition n'a pas marché mais je n'ai pas trouvé de moyen pour effacer complètement mon post. J'ai donc juste supprimé le contenu.]

J'ai rempli les 2 premières lignes de la feuille "Liste"

Ca a l'air de fonctionner.

Je continue ...

Merci à vous 2