VBA Remplacé mon code DoubleClick gauche

Arpette · 7 Février 2011

Bonsoir à toutes et à tous,
je souhaite remplacer mon code ci-dessous, qui s'exécute par un doubleClick gauche par...
Je m'explique : si je saisis une valeur en en A49 une MsgBox me propose s'insérer 55 lignes, si j'accepte = insertion ou si je refuse sort de la macro.
Merci de votre aide
@+

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Dim Q As Integer
    If Intersect(Target, Range("A49")) Is Nothing Then
        Q = MsgBox("Double_Click en cellule A49")
    End If
        If Not Application.Intersect(Target, Range("A49")) Is Nothing Then
            Application.EnableEvents = False
            Rows(Target.Row & ":" & Target.Row + 55).Insert Shift:=xlDown
            Cancel = True
        Application.EnableEvents = True
        End If
End Sub

Banzai64 · 7 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir

A essayer

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Target.Address = "$A$49" Then
    If MsgBox("Voulez-vous insérer 55 lignes ?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
    Application.EnableEvents = False
    Rows(Target.Row & ":" & Target.Row + 55).Insert Shift:=xlShiftDown
    Application.EnableEvents = True
  End If
End Sub

Arpette · 7 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir banzai,
j'ai un message d'erreur "Nom ambigu détecté: Worksheet_Change" quand je saisis une valeur en A49.
Merci de ton aide
@+
C'est ici

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Banzai64 · 7 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir
Dans le code de ta feuille tu n'aurais pas déjà une procédure Private Sub Worksheet_Change(ByVal Target As Range)

Si c'est le cas il faudra mixer les deux procédures

Arpette · 8 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir Banzai, hé oui j'ai déjà la même procédure en début de macro. Donc j'ai rattaché ton code à celle-ci. Le problème est que quand je réponds "non", je ne sorts pas de la procédure.
Merci de ton aide
@+

Banzai64 · 8 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir
Bizarre autant qu'étrange
Postes la procédure
Bonne soirée

Arpette · 8 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Re, voici la procédure et le lien où se trouve le fichier
Cijoint.fr - Service gratuit de dépôt de fichiers

Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pl As Range 'déclare la variable pl (PLage)
Dim r As Range 'déclare la variable r (Recherche)
Dim Cancel As Boolean
Dim Q As Integer
Dim Rep As Integer
Dim n
Dim l
Dim Somme
Dim Somme1
Dim Somme2
If Target.Count > 1 Then Exit Sub
'si la modification a lieu ailleurs qu'en A21:A106, sort de la procédure
If Intersect(Target, Range("A21:A106")) Is Nothing Then Exit Sub
Target = UCase(Target)

With Sheets("Fournisseurs") 'prend en compte l'onglet "Fournisseurs"
    Set pl = .Range("A2:A" & .Range("A65536").End(xlUp).Row) 'définit la plage de recherche
End With 'fin de la prise en compte de l'onglet "Fournisseurs"
 
Set r = pl.Find(Target.Value, , xlValues, xlWhole) 'définit la recherche
If Not r Is Nothing Then 'condition : si il existe au moins une occurrence de B dans la plage pl
    'place le résultat en B,C,E
    Target.Offset(0, 1).Value = r.Offset(0, 1).Value
    Target.Offset(0, 2).Value = r.Offset(0, 2).Value
    Target.Offset(0, 4).Value = r.Offset(0, 4).Value
    Else 'sinon
    MsgBox "Code non trouvé !" 'message
    Exit Sub
End If
'si A est effacée, B,C,D,E,F sont effacées également, sort de la procédure
If Target.Value = "" Then
    Target.Offset(0, 2).Value = ""
    Target.Offset(0, 3).Value = ""
    Target.Offset(0, 4).Value = ""
    Target.Offset(0, 5).Value = ""
    Target.Offset(0, 6).Value = ""
'on recalcule les montants en fonction des suppressions
With Sheets("Devis").Range("D:D")
Somme = 0
Somme1 = 0
Somme2 = 0
    Set n = .Find(what:="T.V.A", LookIn:=xlValues, lookat:=xlWhole)
        If Not n Is Nothing Then
            Somme = Application.WorksheetFunction.Sum(Range("F21:F" & (n.Row - 2))) + Somme
            Somme1 = Somme * n(1, 2) + Somme1
            Somme2 = Somme + Somme1 + Somme2
         End If
    n(0, 3) = Somme 'Montant H.T
    n(1, 3) = Somme1 'Montant T.V.A
    n(2, 3) = Somme2 'Montant T.T.C
End With

: Exit Sub
End If
'ouvre une boite de dialogue pour saisir la quantité
If Cells(Target.Row, 4).Value = "" Then
    Q = InputBox("Saisir Quantité")
    Cells(Target.Row, 4) = Q
    Cells(Target.Row, 6).Value = Cells(Target.Row, 4).Value * Cells(Target.Row, 5).Value
End If
'dès que l'on trouve T.V.A, calcul des différents montants
With Sheets("Devis").Range("D:D")
Somme = 0
Somme1 = 0
Somme2 = 0
    Set n = .Find(what:="T.V.A", LookIn:=xlValues, lookat:=xlWhole)
        If Not n Is Nothing Then
            Somme = Application.WorksheetFunction.Sum(Range("F21:F" & (n.Row - 2))) + Somme
            Somme1 = Somme * n(1, 2) + Somme1
            Somme2 = Somme + Somme1 + Somme2
        End If
    n(0, 3) = Somme 'Montant H.T
    n(1, 3) = Somme1 'Montant T.V.A
    n(2, 3) = Somme2 'Montant T.T.C

  If Target.Address = "$A$49" Then
    If MsgBox("Voulez-vous insérer 55 lignes ?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
    Application.EnableEvents = False
    Rows(Target.Row & ":" & Target.Row + 55).Insert Shift:=xlShiftDown
    Application.EnableEvents = True
  End If
End With
End Sub

Banzai64 · 8 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Bonsoir

Procédure testée avec une version antérieure de ton fichier et pas de soucis

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pl As Range                     'déclare la variable pl (PLage)
Dim r As Range                      'déclare la variable r (Recherche)

  If Target.Count > 1 Then Exit Sub
  
  ' Si la modification a lieu dans la cellule A49 : Soit OUI/NON insertion ligne et on quitte la procédure
  If Target.Address = "$A$49" Then
    If MsgBox("Voulez-vous insérer 55 lignes ?", vbQuestion + vbYesNo) = vbYes Then
      Application.EnableEvents = False
      Rows(Target.Row & ":" & Target.Row + 55).Insert Shift:=xlShiftDown
      Application.EnableEvents = True
    End If
    Exit Sub
  End If
  
  ' Si la modification a lieu ailleurs qu'en A21:A106, sort de la procédure
  If Intersect(Target, Range("A21:A106")) Is Nothing Then Exit Sub
  Application.EnableEvents = False
  Target = UCase(Target)

  If Target.Value = "" Then                                           ' On efface la donnée
    Target.Resize(1, 6).ClearContents
  Else                                                                ' Donc une nouvelle donnée
    With Sheets("Fournisseurs")                                       ' Prend en compte l'onglet "Fournisseurs"
      Set pl = .Range("A2:A" & .Range("A65536").End(xlUp).Row)        ' Définit la plage de recherche
    End With                                                          ' Fin de la prise en compte de l'onglet "Fournisseurs"
 
    Set r = pl.Find(Target.Value, , xlValues, xlWhole)                ' Définit la recherche
    If r Is Nothing Then                                              ' Si pas trouvé on sort
      MsgBox "Code non trouvé !"                                      ' Message
      Application.EnableEvents = True
      Exit Sub
    End If
  
  
    'place le résultat en B,C,E
    Target.Offset(0, 1).Value = r.Offset(0, 1).Value
    Target.Offset(0, 2).Value = r.Offset(0, 2).Value
    Target.Offset(0, 4).Value = r.Offset(0, 4).Value
    
    Cells(Target.Row, 4) = InputBox("Saisir Quantité")
    Cells(Target.Row, 6).Value = Cells(Target.Row, 4).Value * Cells(Target.Row, 5).Value
  End If
  
  With Range("D:D")
    Set r = .Find(what:="T.V.A", LookIn:=xlValues, lookat:=xlWhole)
    If Not r Is Nothing Then
      r(0, 3) = Application.WorksheetFunction.Sum(Range("F21:F" & (r.Row - 2)))   ' Montant H.T
      r(1, 3) = r(0, 3) * r(1, 2)                                                 ' Montant T.V.A
      r(2, 3) = r(0, 3) * r(1, 3)                                                 ' Montant T.T.C
    End If
  End With
  Application.EnableEvents = True
End Sub

Arpette · 8 Février 2011

Re : VBA Remplacé mon code DoubleClick gauche

Re,
merci Banzai, ça fonctionne du tonnerre et de plus je n'ai plus les semis pop-pop lorsque je supprime une donnée.
Merci encore
@+

Effectuez une recherche sur Excel Downloads...

VBA Remplacé mon code DoubleClick gauche

Arpette

XLDnaute Impliqué

Banzai64

XLDnaute Accro

Arpette

XLDnaute Impliqué

Banzai64

XLDnaute Accro

Arpette

XLDnaute Impliqué

Banzai64

XLDnaute Accro

Arpette

XLDnaute Impliqué

Banzai64

XLDnaute Accro

Arpette

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée