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

[Al1_44]

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

 

[sylvanu]

Bonjour AI4_44,

 

[Al1_44]

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é.

 

[sylvanu]

Re,
Avez vous regardez mon image ?

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 :

     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 ?

 

[Al1_44]

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.

 

[Al1_44]

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

 

[sylvanu]

Re,
Impossible de vous aider plus, je ne comprend pas votre code, ni ce qu'il doit faire.
Avant de balancer du code, il vaut mieux expliquer très clairement le but.
( pour le code utilisez les balises </>, à gauche de l'icone GIF, c'est plus lisible )

 

[TooFatBoy]

Bonjour,

Mais je n'arrive pas à faire afficher la date sur la cellule concernée avant la copie.

Est-ce cette ligne qui ne fonctionne pas :

Range("I" & Target.Row).Value = Date

Si oui, essayer d'ajouter WsSrc. devant.

 

[Phil69970]

Bonjour @Al1_44 ,Sylvain et TFB


Juste en passant un essai comme le signale TFB

Il manque un point devant

Range("I" & Target.Row).Value = Date

Ce qui donne :

.Range("I" & Target.Row).Value = Date

Et je dirais aussi qu'il y a peut être un pb ici :

If Intersect(Target, [I2:I65536]) Is Nothing Then Exit Sub

A voir à la place avec :

If Intersect(Target, .[I2:I65536]) Is Nothing Then Exit Sub

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

Merci de ton retour

@Phil69970

 

[Al1_44]

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.

​

 

[Staple1600]

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

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

 

[TooFatBoy]

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

Y a pô comme un pb avec ton fichier ???
Chez moi, en double-cliquant dans une cellule, la macro ne se lance pas... 🤔

 

[Al1_44]

Y a pô comme un pb avec ton fichier ???
Chez moi, en double-cliquant dans une cellule, la macro ne se lance pas... 🤔

Il faut faire un double clic dans une cellule de la colonne I pour archiver une partie de la ligne.

 

[TooFatBoy]

Il faut faire un double clic dans une cellule de la colonne I pour archiver une partie de la ligne.

Au temps pour moi : j'étais pô sur la bonne feuille... 🤪

Et du coup chez moi ça fonctionne.

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]

 

[Phil69970]

Re

Je te propose ceci testé sur mon PC

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