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
485
Al1_44
A
A
  • Résolu(e)
XL 2016 Suivant un double-clic sur une cellule, mettre une couleur sur autres cellules.
Réponses
2
Affichages
304
Al1_44
A
A
  • Résolu(e)
XL 2016 Transfert de formule d'une feuille à une autre.
Réponses
2
Affichages
366
Al1_44
A
chris6999
  • Question
Microsoft 365 Copier une plage vers une autre feuille depuis un USF
Réponses
4
Affichages
152
chris6999
chris6999
Nadou69
  • Résolu(e)
XL 2019 Erreur dans ma macro
Réponses
9
Affichages
293
Nadou69
Nadou69
P
  • Résolu(e)
XL 2016 double filtre
Réponses
9
Affichages
402
Phil69970
Phil69970
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
530
Pac41240
P
T
  • Question
XL 2016 Erreur d'exécution 1004 : Impossible de définir la propriété Hidden de la classe Range
Réponses
3
Affichages
238
Phil69970
Phil69970
Z
  • Question
XL 2016 RECHERCHEV et double liste de choix
Réponses
2
Affichages
680
zendb
Z
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
1 K
job75
job75

Membres actuellement en ligne

3 membres et 49 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
314 499
Messages
2 110 249
Membres
110 711
dernier inscrit
chmessi