Remplacer doubleclik par un bouton

[Mar]

Bonjour,

J'ai réussi à mettre en place une création de feuille automatique sur ma colonne B mais je souhaiterai avoir le même résultats sur ma ligne a et l'instruction doubleclik ne me permet pas cette manipulation car elle est ciblée sur la colonne B.
Je souhaiterai donc créer deux boutons :
Le premier pour créer une feuille à chaque fois que l'on clique dans la colonne B
et recopier la ligne attachée à la cellule
Le second pour créer une feuille à chaque fois que l'on clique dans la ligne A
et recopier la colonne liée à la cellule
Mon code est certainement très imparfait
Merci à tous pour votre aide
Je mets un fichier en exemple
Le code est sur la première feuille

 

[goldenboy]

Re : Remplacer doubleclik par un bouton

Bonjour, et bienvenue sur le forum.

Vous pouvez peut être essayer de remplacer la ligne :

If Target.Column <> 2 Then Exit Sub

Par :

If Target.Column <> 2 And Target.Column <> 1 Then Exit Sub

Cordialement,

 

[Mar]

Re : Remplacer doubleclik par un bouton

Merci pour votre réponse je viens d'essayer votre proposition
puis en remplaçant Column par Target en remplaçant votre proposition
Puis en essayant avec or à la place de and
rien ne fonctionne
code :
If Target.Column <> 2 And Target.Column <> 1 Then Exit Sub ECHEC
If Target.Column <> 2 Or Target.Column <> 1 Then Exit Sub ECHEC
If Target.Column <> 2 And Target.Rows <> 1 Then Exit Sub ECHEC
If Target.Column <> 2 Or Target.Rows <> 1 Then Exit Sub ECHEC
merci

 

[goldenboy]

Re : Remplacer doubleclik par un bouton

Chez moi, cela fonctionne.

Pouvez vous tester le fichier ci joint.

 

[Pierrot93]

Re : Remplacer doubleclik par un bouton

Bonjour,

on peut également le coder ainsi :

If Target.Column > 2 Then Exit Sub

bon après midi
@+

 

[Mar]

Re : Remplacer doubleclik par un bouton

Merci à vous deux j'ai testé mais cela ne fonctionne pas.
C'est pour cela que je pense que deux boutons seraient préférable.

 

[Si...]

Re : Remplacer doubleclik par un bouton

Salut

Intersect permet de mieux cibler la plage. Voir fichier joint.

 

[Mar]

Re : Remplacer doubleclik par un bouton

Merci pour cette proposition qui nettoie sérieusement le code et le rend plus efficace.
Il me reste le problème du traitement de ma ligne deux pour produire les feuilles liées aux lignes 6ac 6de....
Existe-t-il une instruction avec elseif compatible avec le doubleclick ?

 

[Mar]

Re : Remplacer doubleclik par un bouton

Bonsoir,
J'ai résolu ma difficulté tout en conservant l'instruction Worksheet_BeforeDoubleClick
Voir le code
En souhaitant que cela puisse aider d'autres utilisateurs d'excel

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim ws As Worksheet
  Dim i As Integer, DerniereLigne As Integer
  
  If Intersect(Target, Range("B2:AD31")) Is Nothing Then Exit Sub
      For Each ws In Worksheets
    If ws.Name = Target Then
      MsgBox "La feuille avec ce nom existe déjà.", vbCritical, "Impossible de créer une feuille"
      Exit Sub
    End If
    Next
  Sheets.Add , Sheets(Worksheets.Count)
  ActiveSheet.Name = Target
  
 If Target.Row = 2 Then
  
    Range("A2", "A31").Copy
    With Sheets(Target.Text)
    .Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
      
    Range("B2", "B32").Copy
    .Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        ', SkipBlanks:=False, Transpose:=False
          
   [I] Cette partie là ne fonctionne pas !
'Range(Target.Column & "2" & ":c32").Copy
    'With Sheets(Target.Text)
    '.Range("C1").Select
    'Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
       ', SkipBlanks:=False, Transpose:=True[/I]
       
      DerniereLigne = .Range("A65536").End(xlUp).Row
      For i = DerniereLigne To 1 Step -1
       If .Cells(i, 2) = "" Then .Rows(i).Delete
      Next
        
  End With
  End If
  
  If Target.Column = 2 Then
    
    Range("A2", "AL2").Copy
    With Sheets(Target.Text)
    .Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=True
    
    Range("A" & Target.Row).Copy
    .Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
       , SkipBlanks:=False, Transpose:=True
    
    Range("B" & Target.Row & ":AK" & Target.Row).Copy
    .Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
       , SkipBlanks:=False, Transpose:=True
    
    
    
    DerniereLigne = .Range("A65536").End(xlUp).Row
      For i = DerniereLigne To 1 Step -1
        If .Cells(i, 2) = "" Then .Rows(i).Delete
      Next
  End With
  End If
  
    
      
  End Sub