Remplacer "BeforeRightClick" par un ajout automatique

Le 18/03/2019 à 10:23

Bonjour

J'ai trouvé une macro sur un forum pour concevoir un calendrier qui est très bien faite, cependant l'ajout des données au calendrier se faire par clic droit et l'effacement par double clic. Or j'ai beaucoup de données à ajouter (environ 1000 lignes) et qui sont susceptibles de changer à chaque mise à jour.

Code de l'ajout par clic droit :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Not Application.Intersect(Target, Range("$E$2:$E$65000")) Is Nothing Then
  Cancel = True
    ActiveCell.Interior.Color = RGB(250, 250, 210) 
    Nb = 0 '
    dDate = ActiveCell
    mois = Month(ActiveCell)
    If Len(mois) = 1 Then mois = "0" & mois
    annee = Year(ActiveCell)
    feuille = annee & "-" & mois
      With Sheets(feuille)
        For lig = 6 To 16 Step 2
          For col = 3 To 9
            If Sheets(feuille).Cells(lig, col).Value = Day(dDate) Then
              With Worksheets("Base")
                If Sheets(feuille).Cells(lig, col).Offset(1, 0) <> "" Then 
                temp = Sheets(feuille).Cells(lig, col).Offset(1, 0).Value 
                Nb = 1
                End If
                Sheets(feuille).Cells(lig, col).Offset(1, 0) = ActiveCell.Offset(0, -4) & " : " & ActiveCell.Offset(0, -3) & " - " & ActiveCell.Offset(0, -2) & ActiveCell.Offset(0, -1)
                Formater Sheets(feuille).Cells(lig, col).Offset(1, 0), ActiveCell.Offset(0, -4), 0
         Formater Sheets(feuille).Cells(lig, col).Offset(1, 0), ActiveCell.Offset(0, -3), Len(ActiveCell.Offset(0, -4)) + 3
                Formater Sheets(feuille).Cells(lig, col).Offset(1, 0), ActiveCell.Offset(0, -2), Len(ActiveCell.Offset(0, -3)) + Len(ActiveCell.Offset(0, -4)) + 6
                  If Nb = 1 Then 
              Sheets(feuille).Cells(lig, col).Offset(1, 0).Value = Sheets(feuille).Cells(lig, col).Offset(1, 0).Value & Chr(10) & temp
                    Nb = 0
                  End If
              End With
              Exit For
            End If
          Next col
        Next lig
      End With
  End If
Sheets("Base").ACTIVATE
End Sub

Code de la suppression par double-clic :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Application.Intersect(Target, Range("E2:E65000")) Is Nothing Then 
      monText = ActiveCell.Offset(0, -4) & " : " & ActiveCell.Offset(0, -3) & " - " & ActiveCell.Offset(0, -2) & ActiveCell.Offset(0, -1)
    dDate = ActiveCell
        mois = Month(ActiveCell)
            If Len(mois) = 1 Then mois = "0" & mois 
    annee = Year(ActiveCell)
        feuille = annee & "-" & mois 
              With Sheets(feuille)
        For lig = 6 To 16 Step 2 
        For col = 3 To 9             
        If Sheets(feuille).Cells(lig, col).Value = Day(dDate) Then
              Sheets(feuille).Cells(lig, col).Offset(1, 0) = Replace(Sheets(feuille).Cells(lig, col).Offset(1, 0), monText, "")
              Sheets(feuille).Cells(lig, col).Offset(1, 0).Font.Color = RGB(0, 0, 0)
              Sheets(feuille).Cells(lig, col).Offset(1, 0).Font.Bold = False
              Exit For             
              End If
          Next col
        Next lig
      End With
    ActiveCell.Interior.Color = RGB(255, 255, 255) 
    End If
End Sub

Comment puis-je remplacer l'ajout et la suppression par clic par une mise à jour automatique selon si la cellule est vide ou non ?

J'ai fait plusieurs tentatives en vain, étant très très novice en VBA

Merci d'avance de votre aide !

Le 18/03/2019 à 12:20

Bonjour,

Je t'invite à aller faire un tour de ce côté pour voir les différentes possibilité d'exécution automatique d'une macro : https://www.excel-pratique.com/fr/vba/evenements_classeur.php

Sinon, tu peux aussi exécuter une macro à partir d'un bouton, mais il faudra adapter le code ("Target" qui représente la plage/cellule à l'origine de l’exécution automatique disparaît).

Le 18/03/2019 à 13:04

Bonjour Pedro22, merci de ta réponse !

J'ai essayé le SheetChange pour remplacer mais en vain (peut-être parce que je ne sais pas bien l'utiliser aussi).

Je ne comprends pas trop comment adapter le code pour faire fonctionner la macro ?

Sachant qu'en essayant, même en enlevant le Private, je ne la trouve pas pour l'activer...

J'ai aussi essayé d'en faire une boucle mais elle ne se déclenche pas

J'essaie mais je suis un peu perdue face à ces macros

Le 18/03/2019 à 15:13
revmanart a écrit :

Bonjour Pedro22, merci de ta réponse !

J'ai essayé le SheetChange pour remplacer mais en vain (peut-être parce que je ne sais pas bien l'utiliser aussi).

Je ne comprends pas trop comment adapter le code pour faire fonctionner la macro ?

Sachant qu'en essayant, même en enlevant le Private, je ne la trouve pas pour l'activer...

J'ai aussi essayé d'en faire une boucle mais elle ne se déclenche pas

J'essaie mais je suis un peu perdue face à ces macros

Plutôt que de te proposer un code que tu ne maîtriseras pas et sur lequel tu ne seras pas autonome, je te propose de prendre le temps de feuilleter les 2 sections de cours VBA du site. Fais quelques exercices simples et revient nous voir ensuite pour travailler ensemble sur ta problématique.

Le 20/03/2019 à 09:10

J'en ai pas mal feuilleté mais j'avoue avoir peu de temps pour rendre mon document, n'ayant jamais fait de VBA avant c'est compliqué d'en apprendre les bases si rapidement… Merci beaucoup d'avoir pris le temps de me répondre !

J'ai finalement réussi à faire un code fonctionnel, si jamais ça intéresse quelqu'un à l'avenir 

Sub ActiveDbleClick()

Dim ws As Worksheet
Dim LastRow As Long, i As Long
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Set ws = Feuil1
Range("E7").Select
i = 1
For i = 1 To LastRow
Call Worksheet_BeforeDoubleClick(Selection, False)
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value > Range("L3") Then
Exit For
End If
Next i

End Sub
Rechercher des sujets similaires à "remplacer beforerightclick ajout automatique"