Copier auto double clic et selection

[Demouret]

Bonjour le forum..

J'ai trouvé et très legerement bidouillé un code qui permets en double cliquant sur une cellule de copier son contenu et de le coller vers une autre cellule avec clic droit..
C'est excellent mais je voudrai savoir comment etendre la selection selon la valeur d'une cellule adjacente.
J'ai joins un petit fichier car pas simple à expliquer

S'il y avait une bonne ame dans le coin ;-)

Merci de votre aide

 

[cibleo]

Re : Copier auto double clic et selection

Bonsoir à tous,
Bonsoir PMo2,

Je me suis inspiré du travail de bqtr ci-dessus

J'ai donc enlevé les 4 instructions : Plage.Cut Destination:=Target
et ajouté toutes les instructions en couleur ci-dessous, et ça a l'air de fonctionner en partie 🙂

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) 'au clic droit
  '/// ajout Pmo ///
Dim R As Range, [COLOR=darkred]Concat As String[/COLOR]
Set R = Application.Intersect(Target, Range(CHAMP_VALIDE))
If R Is Nothing Then Exit Sub
If Not IsDate(Sh.Name) Then Exit Sub
If NoFormatDate_ddmmyy(Sh.Name) Then Exit Sub
  '/////////////////
If Plage Is Nothing Then Exit Sub
Cancel = True 'évite le menu contextuel lié au clic droit
If ActiveCell <> "" Then
    If MsgBox("Plage horaire déjà prise, voulez-vous remplacer la course déjà saisie ? ", vbYesNo + vbExclamation, "Attention :") = vbYes Then
        [COLOR=darkred]Concat = Concat & Plage & Chr(10)[/COLOR]
        [COLOR=blue]ActiveCell = Left(Concat, Len(Concat) - 1)[/COLOR]
    Else
        If MsgBox("Voulez-vous la placer avant ?", vbYesNo + vbInformation, "Avant ou Après") = vbYes Then
          [COLOR=darkred]Concat = Concat & Plage & Chr(10)[/COLOR]
          [COLOR=darkgreen]ActiveCell = Left(Concat, Len(Concat) - 1) & Chr(10) & Chr(10) & ActiveCell[/COLOR]
        Else
          [COLOR=darkred]Concat = Concat & Plage & Chr(10)[/COLOR]
          [COLOR=darkorange]ActiveCell = ActiveCell & Chr(10) & Chr(10) & Left(Concat, Len(Concat) - 1)[/COLOR]
        End If
     End If
   Else
       [COLOR=darkred]Concat = Concat & Plage & Chr(10)[/COLOR]
       [COLOR=blue]ActiveCell = Left(Concat, Len(Concat) - 1)[/COLOR]
   End If
Set Plage = Nothing
End Sub

En effet, le contenu de la cellule initialement double cliquée ne s'efface plus comme auparavant 😎

Il doit y avoir un dernier petit réglage à effectuer, pouvez vous m'aider ?

Cibleo

 

[PMO2]

Re : Copier auto double clic et selection

Bonjour,

Essayez avec votre code modifié ci-dessous

1) code à copier dans la fenêtre de code de ThisWorkbook

Const CHAMP_VALIDE As String = "C4:M11"

Dim Plage As Range

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) 'au double clic
Dim R As Range
Set R = Application.Intersect(Target, Range(CHAMP_VALIDE))
If R Is Nothing Then Exit Sub
If Not IsDate(Sh.Name) Then Exit Sub
If NoFormatDate_ddmmyy(Sh.Name) Then Exit Sub
  '/////////////////
If Target.Value = "" Then Exit Sub
Cancel = True 'évite le mode édition lié au double-clic
Set Plage = ActiveCell
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) 'au clic droit
Dim R As Range
Dim reponse
Dim A$
Dim Adresse$
Set R = Application.Intersect(Target, Range(CHAMP_VALIDE))
If R Is Nothing Then Exit Sub
If Not IsDate(Sh.Name) Then Exit Sub
If NoFormatDate_ddmmyy(Sh.Name) Then Exit Sub
  '/////////////////
If Plage Is Nothing Then Exit Sub
Cancel = True 'évite le menu contextuel lié au clic droit
If ActiveCell <> "" Then
  A$ = Target
  reponse = MsgBox("Plage horaire déjà prise, voulez-vous remplacer la course déjà saisie ? ", vbYesNo + vbExclamation, "Attention :")
  If reponse = vbYes Then
    Plage.Cut Destination:=Target
  Else
  '//pour mémoire//'reponse = MsgBox("Voulez-vous la placer avant ?", vbYesNo + vbInformation, "Avant ou Après")
    reponse = MsgBoxPerso( _
          Prompt:="Où voulez-vous la placer ?", _
          Title:="Avant ou Après", _
          Icon:=vbExclamation, _
          Caption1:="Avant", Caption2:="Après", Cancel:=True)
    Adresse$ = Target.Address
    If reponse > 0 Then Plage.Cut Destination:=Target
    Select Case reponse
      Case 0
        Set Plage = Nothing
        Exit Sub
      Case 1
        Range(Adresse$) = Range(Adresse$) & Chr(10) & Chr(10) & A$
      Case 2
        Range(Adresse$) = A$ & Chr(10) & Chr(10) & Range(Adresse$)
    End Select
    Range(Adresse$).EntireRow.AutoFit 'permet de régler automatiquement la hauteur de la ligne
  End If
Else
  Plage.Cut Destination:=Target
End If
Set Plage = Nothing
End Sub

Private Function NoFormatDate_ddmmyy(SheetName As String) As Boolean
If CStr(SheetName) <> Format(SheetName, "dd mm yy") Then NoFormatDate_ddmmyy = True
End Function

2) code à copier dans un module Standard. Code de Michel Pierron et Didier Fourgeot qui permet de personnaliser
les MsgBox (c'est plus intuitif pour l'utilisateur de votre deuxième MsgBox)

'========================================================================================================================
' Module de code adapté des excellents travaux de Michel Pierron
' trouvé sur le site  www.excelabo.net
'
' Didier Fourgeot (myDearFriend!) -  www.mdf-xlpages.com
'========================================================================================================================

Private Declare Function SetWindowsHookEx& Lib "USER32" Alias "SetWindowsHookExA" (ByVal idHook&, ByVal lpfn&, ByVal hmod&, ByVal dwThreadId&)
Private Declare Function GetCurrentThreadId& Lib "kernel32" ()
Private Declare Function CallNextHookEx& Lib "USER32" (ByVal hHook&, ByVal CodeNo&, ByVal wParam&, ByVal lParam&)
Private Declare Function GetWindow& Lib "USER32" (ByVal hWnd&, ByVal wCmd&)
Private Declare Function SetWindowText& Lib "USER32" Alias "SetWindowTextA" (ByVal hWnd&, ByVal lpString$)
Private Declare Function UnhookWindowsHookEx& Lib "USER32" (ByVal hHook&)
Private msgHook&
Private TitreBtn$(1 To 2)

Function MsgBoxPerso(Prompt$, Optional Title$, Optional ByVal Icon&, Optional Caption1$ = "Oui", Optional Caption2$ = "Non", Optional Cancel As Boolean = False) As Byte
Dim Rep%, hInstance&
    TitreBtn(1) = Caption1
    TitreBtn(2) = Caption2
    msgHook = SetWindowsHookEx(5, AddressOf CaptionBoutons, hInstance, GetCurrentThreadId())
    Rep = MsgBox(Prompt, Icon + IIf(Cancel, vbYesNoCancel, vbYesNo), Title)
    MsgBoxPerso = Application.Max(Rep - 5, 0)
    Erase TitreBtn
End Function

Private Function CaptionBoutons&(ByVal nCode&, ByVal wParam&, ByVal lParam&)
Dim hWndChild&
  If nCode < 0 Then
    CaptionBoutons = CallNextHookEx(msgHook, nCode, wParam, lParam)
    Exit Function
  End If
  If nCode = 5 Then
    hWndChild = GetWindow(wParam, 5)
    Call SetWindowText(hWndChild, TitreBtn(1))
    hWndChild = GetWindow(hWndChild, 2)
    Call SetWindowText(hWndChild, TitreBtn(2))
    UnhookWindowsHookEx msgHook
  End If
  CaptionBoutons = False
End Function

Cordialement.

PMO
Patrick Morange

 

[cibleo]

Re : Copier auto double clic et selection

Bonjour PMO2,

Ça dépasse l'entendement, tu m'épateras toujours 😱

Pour le libellé des boutons, j'ai inversé le "Avant" "Après" dans l'instruction ci-dessous.

Caption1:="Après", Caption2:="Avant", Cancel:=True)

Quelques remarques et petits réglages parce que je n'ose jamais "tripatouiller" des codes aussi complexes.

Lors de l'apparition de la 1ère MsgBox, je n'ai pas d'autres choix que le "Oui" et le "Non", peut-on rajouter le bouton "Annuler".

De plus, la croix rouge de fermeture de cette MsgBox ne fonctionne pas 😕

Autre point sur la personnalisation de la 2ème MsgBox :

Il doit y avoir un petit bug.

Dans cette 2ème MsgBox, les 3 boutons sont disposés et libellés dans cet ordre : Avant, Après et annuler.

Mais je vois apparaître les 3 boutons libellés comme ceci :
Avant, Non et annuler ;

et j'ai le libellé "Après" qui se retrouve placé à gauche du bouton "Avant" sur le fond de la Msgbox 😎

Y a t-il une erreur de programmation ou c'est mon PC qui débloque ?

L'un d'entre vous peut-il me signaler s'il constate le même bug chez lui ?

Sinon, le résultat souhaité est obtenu 🙂

Peux-tu une nouvelle fois intervenir ?

Bon week-end à tous
Cibleo

 

[PMO2]

Re : Copier auto double clic et selection

Bonjour,

Essayez avec cette nouvelle pièce jointe.

Cordialement.

PMO
Patrick Morange

 

[cibleo]

Re : Copier auto double clic et selection

Bonjour PMO2,
Merci de me consacrer tout ce temps.

A propos de la personnalisation de la 2ème Msgbox, je ne comprends pas, l'effet décrit plus haut se reproduit 😕

Est-ce mon Excel qui bug ? Je vais tester le fichier sur un autre PC demain.

Sinon pour le reste, c'est tout bon.

D'autre part, dans la 1ère MsgBox, j'aimerais compléter le Prompt avec le Nom du chauffeur se trouvant dans la colonne B au même niveau que la cellule active.

Exemple : Plage horaire déjà prise, voulez-vous remplacer la course attribuée à Fabienne"

reponse = MsgBox( _
          Prompt:="Plage horaire déjà prise, voulez-vous remplacer la course [B][COLOR=darkred]déjà saisie[/COLOR][/B] ? ",

Après ceci, je pense en avoir fini 🙄

A+ Cibleo

 

[PMO2]

Re : Copier auto double clic et selection

Bonjour,

Remplacez

reponse = MsgBox( _
          Prompt:="Plage horaire déjà prise, voulez-vous remplacer la course déjà saisie ? ", etc

par

  reponse = MsgBox( _
          Prompt:="Plage horaire déjà prise, voulez-vous remplacer la course attribuée à " & Range("b" & Target.Row & "") & " ? ", _
          Buttons:=vbYesNoCancel + vbExclamation, Title:="Attention :")

Cordialement.

PMO
Patrick Morange

 

[cibleo]

Re : Copier auto double clic et selection

Bonjour à tous,
Bonjour PMO2,

Pour bien visualiser le problème, voilà comment apparaît chez moi la MsgBox personnalisée dans ton fichier joint.



Je vais faire un petit tour sur le site de myDearFriend pour essayer de trouver un début de solution.

Sinon, j'opterai pour une MsgBox classique.

Amicalement Cibleo

 

[PMO2]

Re : Copier auto double clic et selection

Bonjour,

Suite au problème que vous rencontrez avec l'usage d'une MsgBox personnalisée et comme je n'ai aucune idée de sa cause voici une autre piste utilisant un UserForm (on oublie par conséquent la MsgBox personnalisée).

Veuillez vous référer à l'exemple joint pour y récupérer le nouveau code de ThisWorkbook, le code des variables publiques dans le module1, le UserForm qui sera à copier/importer dans votre projet.

Cordialement.

PMO
Patrick Morange

 

[cibleo]

Re : Copier auto double clic et selection

Bonsoir à tous,
Bonsoir PMO2,

Tout fonctionne à merveille et je te remercie 🙂

Je reviens avec l'évènement "SheetBeforeDoubleClick" et j'illustre à nouveau.

Mon planning se composera donc de courses comme dans l'image jointe, pas plus de 3 comme en C4.

Et pour bien les discerner, elles seront toujours séparées par un interligne.


Si je double clic sur C4 puis clic droit sur F4, le coller de C4 soit les 3 courses se fera donc intégralement en F4.

J'aimerais, si c'était possible, effectuer un choix pour le "Couper"

Ainsi, au double clic, ne peut-on pas faire apparaitre un formulaire composé d'une listbox multiselect dans laquelle l'on pourrait visualiser l'intégralité du contenu de la cellule double cliquée ?

A partir de là, les items sélectionnés formeraient alors le "Couper" destiné à être coller.

Je vois les choses comme ça, s'il y a plus simple, je suis preneur.

Bonne soirée Cibleo

 

[cibleo]

Re : Copier auto double clic et selection

Re PMO2,

Après réflexion, je crois que je vais abandonner l'idée du formulaire et de la sélection des items : pas très ergonomique, trop fastidieux à manipuler.

Par contre, ne pourrait-on pas déterminer la partie du contenu de la cellule à "Couper" par la position du curseur dans la dite cellule au moment du double-clic ?

Exemple : en C4, je double clique sur le mot "Airoux" et ce sont le bloc des 4 lignes concernées qui composeront le "Couper".

Est-ce réalisable ?

Si oui, comment devra alors s'effectuer le choix de l'intégralité du contenu de la cellule, ce qui est déjà réalisé dans le code initial.

Un peu complexe ma demande 😎

Je vous rassure, il n'y a rien d'urgent.

A+ Cibleo

 

[cibleo]

Re : Copier auto double clic et selection

Bonjour le forum,
Bonjour PMO2,

Résumons :

J'aimerais poursuivre le superbe travail de PMO2 en effectuant 1 "Couper partiel" d'une cellule (au double clic) pour enchainer avec le "Coller" (clic droit).

Je reviens donc sur ma première idée.

- Au double clic (ici en C4), charger le formulaire non modal en affichant le contenu de la cellule pointée dans la Listbox1.
- Sélectionner 2 items de la Listbox1 pour constituer le "Couper" dans la TextBox1.

Ces 2 premiers points sont illustrés dans l'image jointe.



Enfin, dans un 3ème temps, le clic droit devra effectuer le "Coller" dans la cellule pointée avec le contenu de la TextBox1.

C'est ce 3ème point que j'aimerais développer avec vous en modifiant les 2 macros événementielles de PMO2 placées dans le ThisWorkbook.

Pouvez-vous à nouveau me venir en aide ?

Bonne soirée Cibleo

 

[cibleo]

Re : Copier auto double clic et selection

Bonjour à tous,
Bonjour PMO2,

Je me permets de faire remonter le fil, PMO2 étant connecté.

Cibleo