Microsoft 365 Copier cellule active et une autre cellule sur une autre feuille

[Francky79]

Bonjour le forum,

Comment modifier le code ci-dessous pour copier la cellule active positionnée dans la colonne C et la cellule de la colonne I de la même ligne de la feuille 1 sur la feuille 2 en mettant la cellule active dans la colonne D et la cellule de la colonne I en colonne J ?

Sub Copie3()
Dim Ligne As Long

Ligne = Sheets("Feuil2").Cells(Rows.Count, "C").End(xlUp).Row + 1

ActiveCell.Offset(, 0).Copy Sheets("Feuil2").Range("C" & Ligne)
End Sub

Merci de votre aide,

 

[soan]

Bonjour Francky79,

je te propose ce code VBA :

Sub Copie3()
  Dim sh As Worksheet, lig&: Application.ScreenUpdating = 0
  Set sh = Worksheets("Feuil2"): lig = sh.Cells(Rows.Count, 3).End(3).Row + 1
  With Worksheets("Feuil1").Cells(lig, 3)
    sh.Cells(lig, 4) = .Value: sh.Cells(lig, 10) = .Offset(, 6)
  End With
End Sub

soan

 

[Francky79]

Merci soan pour ton aide,

Mais je voudrais sélectionner la cellule active.
Voir fichier joint pour plus d'explications.

Merci,

 

[soan]

@Francky79

ton fichier en retour.

sur "Feuil2", tu peux voir que j'ai mis d'autres nombres, pour mieux différencier les 2 colonnes ; note bien que D5 et J5 sont vides ; va sur "Feuil1" ; bien sûr, là aussi, j'ai changé les nombres pour mieux différencier les 2 colonnes ; sélectionne C4 ; clique sur ton bouton "Enveloppe", puis retourne sur "Feuille2" ; en D5 : 14, et en J5 : 24 ➯ problème résolu ! attention : si une cellule source de "Feuil1" est vide (en colonne C ou i), elle ne sera PAS copiée ! donc en "Feuil2", ça pourra arriver que les colonnes D et J n'ont PAS la MÊME HAUTEUR ! comme tu ne m'as rien dit à propos des cellules vides, j'ai choisi cette façon de faire, mais au besoin, tu pourras facilement modifier ce code VBA :​

Option Explicit

Sub Copie3()
  If ActiveSheet.Name <> "Feuil1" Then Exit Sub
  Dim sh As Worksheet, cel As Range, nlm&, lg1&, lg2&
  Set cel = ActiveCell: If cel.Column <> 3 Then Exit Sub
  Set sh = Worksheets("Feuil2"): nlm = Rows.Count
  lg1 = cel.Row: Application.ScreenUpdating = 0
  lg2 = sh.Cells(nlm, 4).End(3).Row + 1
  If cel <> "" Then sh.Cells(lg2, 4) = cel
  lg2 = sh.Cells(nlm, 10).End(3).Row + 1
  If cel.Offset(, 6) <> "" Then _
    sh.Cells(lg2, 10) = cel.Offset(, 6)
End Sub

soan

 

[Francky79]

Bonjour soan,

Merci de ton aide, la modification me semble parfaite.

Bonne journée