XL 2016 Copier coller par double clic, erreur de compilation.

A

Al1_44

XLDnaute Junior
Bonjour à tous,

Suite à une transformation d'un code de Phil69970, respect pour la source.
Je fais un double clic dans la colonne "I" je met la date du jour dans la cellule de la colonne "I" sélectionnée,
puis faire un transfert en feuille 2 de la ligne "I" à "AC".
Cela fonctionne avec un commandbutton mais pas avec la fonction double clic qui me renvoie une erreur de compilation?

AL1_44
 

Pièces jointes

  • Archivage.xlsm
    33.9 KB · Affichages: 2
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour AI4_44,
1679832937248.png
 
Vote positif 0 Vote négatif
A

Al1_44

XLDnaute Junior
Bonjour Sylvanu,

Cette condition : " If WsSrc.Range("AJ" & i) = "x" Then" fonctionne très bien avec l'évènement
"Private Sub CommandButton1_Click() "
En désactivant cette condition pour travailler avec un double clic "If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub" j'ai le message d'erreur End if sans boc if.
Ci-joint le fichier épuré.
 

Pièces jointes

  • Archivage V1.xlsm
    35.2 KB · Affichages: 1
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Avez vous regardez mon image ?
VB: 
If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
Ici vous avez un IF et l'action qui suit le Then. Donc c'est ok pour ce IF.
Ensuite :
Code: 
     End If 
Next i
Ce End If ne correspond à aucun IF donc il génère une erreur.
Supprimez ce End If. et testez. Ca marche mieux.

Mais vous avez un autre souci. Je ne comprends pas votre Msgbox. Il est réitérer pour toutes les lignes. C'est ce que vous voulez faire ?
 
Vote positif 0 Vote négatif
A

Al1_44

XLDnaute Junior
Oups, j'ai zappé le Then !
Une information complémentaire, dans la colonne "I", il peut y avoir une valeur ou pas.
Lorsque je double clic sur une cellule de la colonne "I' la date du jour devrait s'afficher.
Le message est juste là pour moi, afin de vérifier que l'action est faite.
Effectivement j'ai un souci car en retirant End if, ça tourne en boucle sans pour autant mettre la date
dans la cellule concernée.
En plus cela transfère plusieurs lignes d'un coup.
 
Vote positif 0 Vote négatif
A

Al1_44

XLDnaute Junior
Merci Sylvanu de m'interroger sur ce que je souhaitais obtenir.
J'ai retirer la boucle et je suis passé par la fonction Target.row, et cela fonctionne.
Mais je n'arrive pas à faire afficher la date sur la cellule concernée avant la copie.
Certainement trop simple..

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Dim WsDst As Worksheet, WsSrc As Worksheet, i&, DerligSrc&, DerligDst&, Cptr&
Set WsSrc = Worksheets("Feuil1"): Set WsDst = Worksheets("Feuil2")

DerligSrc = WsSrc.Range("I" & Rows.Count).End(xlUp).Row
DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1

With WsDst
If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
Cancel = True

Range("I" & Target.Row).Value = Date
MsgBox ("Date d'enregistrement")

WsDst.Range("A" & DerligDst).Resize(, 21) = WsSrc.Range("I" & Target.Row & ":AC" & Target.Row).Value
WsDst.Range("A" & DerligDst).Resize(, 21).Interior.Color = RGB(146, 208, 80)
DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Delete
End With
MsgBox ("La ligne a été archivée")
WsDst.Activate

Set WsDst = Nothing: Set WsSrc = Nothing
End Sub
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Bonjour @Al1_44 ,Sylvain et TFB


Juste en passant un essai comme le signale TFB

Il manque un point devant
Al1_44 à dit:
Range("I" & Target.Row).Value = Date
Cliquez pour agrandir...

Ce qui donne :
.Range("I" & Target.Row).Value = Date
Cliquez pour agrandir...

Et je dirais aussi qu'il y a peut être un pb ici :
Al1_44 à dit:
If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
Cliquez pour agrandir...

A voir à la place avec :
If Intersect(Target, .[I2:I65536]) Is Nothing Then Exit Sub
Cliquez pour agrandir...

Sans vu d'ensemble difficile d'être plus précis

Merci de ton retour

@Phil69970
 
Vote positif 0 Vote négatif
A

Al1_44

XLDnaute Junior
Sylvanu,
Je ne viens pas souvent sur le forum et je n'ai pas encore acquis les us du site.
Je vais davantage joindre un fichier, cela sera plus simple pour moi.
j'ai en partie résolu ma demande sur le transfert de la ligne sélectionnée par le double clic.

Il me reste à trouver le code qui permettra d'afficher la date du jour lorsque l'on double clic sur une cellule de la colonne "I", avant d'archiver la ligne en question.

Merci TooFatBoy pour ton aide mais j'avais déjà essayé sans succès.

​

 

Pièces jointes

  • Archivage V2.xlsm
    32.8 KB · Affichages: 5
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil,

@Al1_44
[Juste pour infos]
En utilisant les balises BBCODE idoines
[CODE] le code VBA[/CODE]
Ton message sera plus facile à lire
Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Dim WsDst As Worksheet, WsSrc As Worksheet, i&, DerligSrc&, DerligDst&, Cptr&
Set WsSrc = Worksheets("Feuil1"): Set WsDst = Worksheets("Feuil2")

DerligSrc = WsSrc.Range("I" & Rows.Count).End(xlUp).Row
DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1

With WsDst
If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
Cancel = True

Range("I" & Target.Row).Value = Date
MsgBox ("Date d'enregistrement")

WsDst.Range("A" & DerligDst).Resize(, 21) = WsSrc.Range("I" & Target.Row & ":AC" & Target.Row).Value
WsDst.Range("A" & DerligDst).Resize(, 21).Interior.Color = RGB(146, 208, 80)
DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Delete
End With
MsgBox ("La ligne a été archivée")
WsDst.Activate

Set WsDst = Nothing: Set WsSrc = Nothing
End Sub
 
Vote positif 0 Vote négatif
TooFatBoy

TooFatBoy

XLDnaute Barbatruc
Al1_44 à dit:
Il faut faire un double clic dans une cellule de la colonne I pour archiver une partie de la ligne.
Cliquez pour agrandir...
Au temps pour moi : j'étais pô sur la bonne feuille... 🤪

Et du coup chez moi ça fonctionne.
VB: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim WsDst As Worksheet, WsSrc As Worksheet, i&, DerligSrc&, DerligDst&, Cptr&

    Application.ScreenUpdating = False

    Set WsSrc = Worksheets("Feuil1")
    Set WsDst = Worksheets("Feuil2")
    DerligSrc = WsSrc.Range("I" & Rows.Count).End(xlUp).Row
    DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1

    With WsDst
        If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
            Cancel = True

            If MsgBox("Etes-vous certain de vouloir archiver la ligne ?", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub
            Target.Value = Date
            MsgBox (Target.Worksheet.Name & "!" & Target.Address & " = " & Target.Value)
       
            WsDst.Range("A" & DerligDst).Resize(, 21) = WsSrc.Range("I" & Target.Row & ":AC" & Target.Row).Value
            WsDst.Range("A" & DerligDst).Resize(, 21).Interior.Color = RGB(146, 208, 80)
            DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1
            Target.EntireRow.Delete
    End With

    MsgBox ("La ligne a été archivée")
    WsDst.Activate

    Set WsDst = Nothing
    Set WsSrc = Nothing

End Sub


[edit]
Code de la macro modifié ici avec la proposition du message #17.
[/edit]
 
Dernière édition:
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Re

Je te propose ceci testé sur mon PC

VB: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Dim WsDst As Worksheet, WsSrc As Worksheet, i&, DerligSrc&, DerligDst&, Cptr&
Set WsSrc = Worksheets("Feuil1"): Set WsDst = Worksheets("Feuil2")

DerligSrc = WsSrc.Range("I" & Rows.Count).End(xlUp).Row
DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1

With WsDst
    If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub
        Cancel = True
   
    If MsgBox("Etes-vous certain de vouloir archiver la ligne ?", vbYesNo, "Demande de confirmation") = vbNo Then
        Exit Sub
    Else
         MsgBox ("Date d'enregistrement")     'Message pour vérifier si la date s'inscrit dans la colonne I avant transfert.
       
         WsDst.Range("A" & DerligDst).Resize(, 21) = WsSrc.Range("I" & Target.Row & ":AC" & Target.Row).Value
         WsDst.Range("A" & DerligDst).Resize(, 21).Interior.Color = RGB(146, 208, 80)
        .Range("I" & DerligDst) = Date
         DerligDst = WsDst.Range("A" & Rows.Count).End(xlUp).Row + 1
         Target.EntireRow.Delete
    End If
End With
MsgBox ("La ligne a été archivée")
WsDst.Activate

Set WsDst = Nothing: Set WsSrc = Nothing

End Sub

Merci de ton retour

@Phil69970
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2016 Ajouter une formule à une ligne lors d'un transfert entre deux onglets
Réponses
6
Affichages
285
Al1_44
A
E
  • Résolu(e)
Microsoft 365 copier coller Resize
2 3 4
Réponses
56
Affichages
1 K
Phil69970
Phil69970
A
  • Résolu(e)
XL 2016 Plage de données fixes pour calcul dans formule
Réponses
3
Affichages
108
sylvanu
sylvanu
J
  • Question
XL 2016 envoie mail automatique lors de double-clic sur cellule
Réponses
6
Affichages
261
J@ba
J
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
186
aziz
A
O
  • Question
XL 2016 Erreur d'exécution 32809 Erreur définie par l'application ou par l'objet
Réponses
0
Affichages
155
Oddoneju
O
H
  • Question
XL 2016 double clic pour aller à la ligne
Réponses
5
Affichages
474
Oneida
Oneida
A
  • Résolu(e)
XL 2016 Transfert de données sous condition entre 2 classeurs
Réponses
2
Affichages
230
Al1_44
A
C
  • Résolu(e)
Microsoft 365 Copier-coller et création onglet avec Double clic
Réponses
3
Affichages
495
chrislam86
C
B
  • Question
Microsoft 365 Erreur de compilation
Réponses
3
Affichages
523
oguruma
oguruma

Membres actuellement en ligne

16 membres et 152 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 211
Messages
2 086 292
Membres
103 171
dernier inscrit
clemm