XL 2016 annulation ou désactivation de macro

[richardlion]

Bonjour a tous, je viens vers vous pour essayer de trouver une solution a mon probleme,
j'ai une macro ci dessous qui par un clic droit copie vers une autre feuille dans des cellules une ligne de donnée d'un tableau structuré. je ne souhaite pas que cette copie soit permanente je souhaite pouvoir l'annuler pour revenir aux donnees original
est t'il possible d'avoir une macro qui fasse cette annulation. merci a vous
en Pj le fichier
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LO As ListObject, c As Range
For Each LO In ListObjects
LO.Range.Interior.ColorIndex = xlNone
Next LO
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
For Each LO In ListObjects
Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
c(1, 2).Resize(, 8).Interior.Color = vbYellow
Next LO
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range, col%
Cancel = True
For Each LO In ListObjects
Set c = LO.Range(Target.Row - ListObjects(1).Range.Row + 1, 1)
Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
col = Application.Match(CLng(CDate(LO.Range(0, 1))), cc.EntireRow, 0) 'recherche la colonne de la date
cc(2, col).Resize(8) = Application.Transpose(c(1, 2).Resize(, 8))
cc(2).Resize(7).EntireRow.Interior.ColorIndex = xlNone 'RAZ
cc(2, col).Resize(7).Interior.Color = vbYellow
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

 

[sylvanu]

Bonsoir,
D'accord avec Vgendron. Dans votre PJ il n'y a aucune formule.
Alors mettez un fichier vraiment représentatif, ne serait ce que pour les tests.

 

[job75]

Bonsoir à tous,

A priori il suffit de remplace Value par Formula dans les macros Sauvegarde et Annulation.

A+

 

[richardlion]

Bonjour a tous, en PJ le fichier avec les formules basique de recherche V ou X qui ne concerne que la colonne A et D.

 

[sylvanu]

Bonjour,
Un mélange entre copier coller formules pour A.D et copier coller valeurs pour le reste, avec :

Dim F, DL%, DC%
Set F = Sheets("SYNTHESE")
With Sheets("Sauvegarde")
    .Cells.Clear
    DL = F.Cells(F.Cells.Rows.Count, "A").End(xlUp).Row
    DC = F.Cells(9, F.Columns.Count).End(xlToLeft).Column
    .Range(.Cells(1, 1), .Cells(DL, 4)) = F.Range(F.Cells(1, 1), F.Cells(DL, 4)).Formula
    .Range(.Cells(1, 5), .Cells(DL, DC)) = F.Range(F.Cells(1, 5), F.Cells(DL, DC)).Value
    .[A1] = L: .[A2] = DL: .[A3] = DC
End With
End Sub
Sub Annulation()
Dim F, DL%, DC%
Set F = Sheets("Sauvegarde")
With Sheets("SYNTHESE")
    DL = F.[A2]: DC = F.[A3]
    .Range(.Cells(1, 1), .Cells(DL, 4)) = F.Range(F.Cells(1, 1), F.Cells(DL, 4)).Formula
    .Range(.Cells(1, 5), .Cells(DL, DC)) = F.Range(F.Cells(1, 5), F.Cells(DL, DC)).Value
    .[A1:A3].ClearContents
    MsgBox "Annulation du transfert dû" & Chr(10) & "au clic droit sur la ligne " & F.[A1]
End With
End Sub

 

[job75]

Bonjour richardlion, sylvanu,

Pourquoi ne pas tout traiter avec Formula (une ligne dans chaque macro comme indiqué au post #17) ?

A+

 

[sylvanu]

Bonjour Job,

Pourquoi ne pas tout traiter avec Formula (une ligne dans chaque macro comme indiqué au post #17) ?

Juste pour la lisibilité et aider Richardlion à comprendre la macro et pouvoir la modifier.
La lisibilité aide la maintenance, et c'est toujours ma façon de procéder. 🙂

 

[job75]

A quoi sert l'annulation indiquée ici ?

En effet si l'on fait plusieurs clics droits de suite sans annuler, l'annulation redonnera l'état après l'avant-dernier clic droit.

Il n'y a pas moyen de revenir à l'état initial, c'est à dire d'annuler tous les clics droits.

 

[sylvanu]

En effet si l'on fait plusieurs clics droits de suite sans annuler, l'annulation redonnera l'état après l'avant-dernier clic droit.

J'ai traduit par un équivalent de Ctrl+Z.

 

[job75]

De toute façon le fichier du post #18 n'a ni queue ni tête, richardlion ne sait pas ce qu'il veut.

 

[job75]

Bonjour richardlion, le forum,

Puisque vous ne vous manifestez pas j'ai modifié votre fichier avec celui de l'autre fil (resté en suspens) :

https://excel-downloads.com/threads...cle-dentree-a-la-date.20086780/#post-20684052

Il y a des couleurs modifiées dans la feuille SYNTHESE donc le mieux est de tout sauvegarder :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim c As Range, LO As ListObject, cc As Range, col%
Cancel = True
SauvegardeAnnulation
For Each c In Sheets("SYNTHESE").UsedRange.Columns("D:F").Cells
    If IsDate(c) Then c(2).Resize(7).Interior.ColorIndex = xlNone 'RAZ sous les dates
Next c
For Each LO In ListObjects
    Set c = LO.Range(Target.Row - ListObjects(1).Range.Row + 1, 1)
    Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
    col = Application.Match(CLng(CDate(LO.Range(0, 1))), cc.EntireRow, 0) 'recherche la colonne de la date
    cc(2, col).Resize(8) = Application.Transpose(c(1, 2).Resize(, 8))
    cc(2, col).Resize(7).Interior.Color = vbYellow
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

Sub SauvegardeAnnulation()
Dim test As Boolean
test = IsError(Application.Caller)
Sheets(IIf(test, "SYNTHESE", "Sauvegarde")).Cells.Copy Sheets(IIf(test, "Sauvegarde", "SYNTHESE")).Cells
If Not test Then MsgBox "Annulation effectuée..."
End Sub

Sub Réinitialisation()
Sheets("Réinitialisation").Cells.Copy Sheets("SYNTHESE").Cells
MsgBox "Réinitialisation effectuée..."
End Sub

La macro Réinitialisation remet la feuille SYNTHESE dans son état initial.

Nota : dans les formules en colonne D de la feuille SYNTHESE vous avez oublié de mettre des signes $ sur les plages de Feuil1.

Afin de figer les lignes quand on tire les formules vers le bas.

A+

 

[job75]

Bonsoir le forum,

Je reviens sur ce fil avec une question : que faut-il faire s'il y a des objets dans la feuille SYNTHESE ?

Alors voilà :

Dim source As Worksheet, destination As Worksheet, mess$ 'mémorise les variables

Sub SauvegardeAnnulation()
Dim test As Boolean
test = IsError(Application.Caller)
Set source = Sheets(IIf(test, "SYNTHESE", "Sauvegarde"))
Set destination = Sheets(IIf(test, "Sauvegarde", "SYNTHESE"))
mess = IIf(test, "", "Annulation effectuée...")
CopieTout
End Sub

Sub Réinitialisation()
Set source = Sheets("Réinitialisation")
Set destination = Sheets("SYNTHESE")
mess = "Réinitialisation effectuée..."
Application.Goto [A1]
CopieTout
End Sub

Sub CopieTout()
Dim o As Object
destination.DrawingObjects.Delete 'RAZ
source.Shapes.AddLine(0, 0, 100, 100).Name = Chr(1) '1ère Shape auxiliaire
source.Shapes.AddLine(0, 10, 100, 110).Name = Chr(2) '2ème Shape auxiliaire pour avoir au moins 2 objets
With source.DrawingObjects
    .Placement = 3 'évite de copier les objets
    source.Cells.Copy destination.Cells 'copie toutes les cellules
    .Placement = 2
    Set o = .Group 'groupe
End With
o.Copy 'copie le groupe
destination.Paste 'colle le groupe
With destination.DrawingObjects(1)
    .Top = o.Top: .Left = o.Left
    .Ungroup: o.Ungroup 'dissocie
End With
source.Shapes.Range(Array(Chr(1), Chr(2))).Delete
destination.Shapes.Range(Array(Chr(1), Chr(2))).Delete
Sheets("SYNTHESE").Visible = xlSheetHidden: Sheets("SYNTHESE").Visible = xlSheetVisible 'gymnastique utile pour l'affichage
If mess <> "" Then MsgBox mess
End Sub

A+