transférer le contenu de plusieurs cellules

[kinel]

Bonjour le forum

je voudrai intégrer une macro qui me permette de transférer le contenu de plusieurs cellules vers d'autres sans modifier le format et seulement si la destination est vide

vous aurez une idée plus précise de ma recherche dans le fichier joint

Merci de votre aide

Kinel

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

Bonjour.
Un clic droit sur n'importe quelle cellule, ça vous irait ? Enfin deux consécutifs plutôt, le 2ième échange les contenus des deux lignes :

Option Explicit
Dim NLigEch As Long

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim T() As Variant
If NLigEch > 0 Then
   If Target.Row <> NLigEch Then
      Application.EnableEvents = False
      T = Me.[C:H].Rows(NLigEch).Value
      Me.[C:H].Rows(NLigEch).Value = Me.[C:H].Rows(Target.Row).Value
      Me.[C:H].Rows(Target.Row).Value = T
      Application.EnableEvents = True
      End If
   NLigEch = 0
Else: NLigEch = Target.Row: End If
Cancel = True
End Sub

À mettre en tête du module de la feuille, devant la Worksheet_Change.

 

[kinel]

Re : transférer le contenu de plusieurs cellules

Bonjour Dranreb

bravo ! ça correspond bien à la réalité du terrain
je vais essayer d'y mettre quand même une sécurité au premier clic droit par un msgbox qui proposera de continuer la procédure ou de l'arrêter.

Merci beaucoup
kinel

 

[kinel]

Re : transférer le contenu de plusieurs cellules

au secours Dranreb

je n'arrive pas à ajouter ce msgbox pour confirmer ou annuler la procédure au premier clic droit

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

Pour annuler il suffit d'un clic droit sur la même ligne. Mais c'est vrai que rien n'indique qu'un processus d'échange est entamé. Essayons de ne pas alourdir de la manoeuvre supplémentaire de cliquer sur un bouton en utilisant déjà la barre d'état :

Option Explicit
Dim NLigEch As Long, SvgAffBarÉtat As Boolean

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim T() As Variant
If Target.Row < 3 Then Exit Sub
If NLigEch = 0 Then
   NLigEch = Target.Row
   SvgAffBarÉtat = Application.DisplayStatusBar
   Application.DisplayStatusBar = True
   Application.StatusBar = "Ligne " & NLigEch & " à échanger, clic droit sur la même pour annuler."
Else
   If Target.Row <> NLigEch Then
      Application.EnableEvents = False
      T = Me.[C:H].Rows(NLigEch).Value
      Me.[C:H].Rows(NLigEch).Value = Me.[C:H].Rows(Target.Row).Value
      Me.[C:H].Rows(Target.Row).Value = T
      Application.EnableEvents = True
      End If
   NLigEch = 0
   Application.DisplayStatusBar = SvgAffBarÉtat: Application.StatusBar = False
   End If
Cancel = True
End Sub

On peut aussi prévoir une sécurité à l'aide de deux procédures: Double clic pour noter la 1ère ligne, Clic droit pour effectuer l'échange. Faire un petit userform affiché non modal si la barre d'état est trop discrète et toujours affichée chez vous. Dites ce que vous voulez. Si non le msgbox devrait se mettre du coté du cas où NLigEch = 0

 

[kinel]

Re : transférer le contenu de plusieurs cellules

ça c'est génial mais je crains fort que mes collègues ne le voient pas et me mélange tout le contenu du tableau involontairement

j'opterais plutôt pour un bon msqbox qui vient éblouir l'utilisateur pour plus de sécurité

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

Le MsgBox pourrait s'écrire comme ça :

If MsgBox("Attribution de chambre" & vbLf & "à intervertir…", _
      vbOKCancel + vbInformation, "Clic droit sur la ligne") = vbCancel Then Exit Sub

Mais tant qu'à faire un Userform affiché tant que l'opération n'aura pas été achevée ou annulée serait mieux.
Il serait possible aussi de combiner quelque chose avec un Application.InputBox (à ne pas confondre avec la fonction InputBox de VBA qui ne permet la saisie d'une réf de cellule).

 

[mapomme]

Re : transférer le contenu de plusieurs cellules

Bonjour kinel, Dranreb,

J'avais commencé quelque chose à base de inputbox. Comme on en parle, je joins la chose (moins élégant que le code de Dranreb que je salue ) (utiliser le double-clique)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim xvers As Range, Tablo As Range, xcell As Range, ligne As String, T, rep

Cancel = True
Set Tablo = Range(Range("b3"), Range("H" & Range("b" & Rows.Count).End(xlUp).Row))
If Not Intersect(Target, Tablo) Is Nothing Then
  On Error Resume Next
  Set xvers = Application.InputBox("Sélectionner une cellule de la ligne destination.", , , , , , , 8)
  If Not xvers Is Nothing Then
    On Error GoTo 0
    If Not Intersect(xvers(1, 1), Tablo) Is Nothing Then
      For Each xcell In Cells(xvers.Row, "c").Resize(1, 6)
        ligne = ligne & xcell
      Next xcell
      If Trim(ligne) = "" Then
        Cells(xvers.Row, "c").Resize(1, 6).Value = Cells(Target.Row, "c").Resize(1, 6).Value
        Cells(Target.Row, "c").Resize(1, 6).ClearContents
      Else
        rep = MsgBox("Le lit de destination est déjà occupé ! " & vbLf & vbLf & _
            "Voulez-vous intervertir de lit les deux patients ?", _
            vbYesNo + vbDefaultButton2 + vbCritical)
        If rep = vbYes Then
          T = Cells(xvers.Row, "c").Resize(1, 6).Value
          Cells(xvers.Row, "c").Resize(1, 6).Value = Cells(Target.Row, "c").Resize(1, 6).Value
          Cells(Target.Row, "c").Resize(1, 6) = T
        Else
          MsgBox "Opération annulée"
        End If
      End If
    End If
  End If
End If
End Sub

Edit : bonjour job75

 

[job75]

Re : transférer le contenu de plusieurs cellules

Bonjour kinel, Dranreb,

On peut aussi utiliser ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count <> 2 Then Exit Sub
Dim P1 As Range, P2 As Range
Set P1 = Intersect(Target.Areas(1).Cells(1).EntireRow, [C:H])
Set P2 = Intersect(Target.Areas(2).Cells(1).EntireRow, [C:H])
If P1.Row < 3 Or P2.Row < 3 Then Exit Sub
Application.EnableEvents = False
If Application.CountA(P1) And Application.CountA(P2) = 0 Then
  P2 = P1.Value
ElseIf Application.CountA(P2) And Application.CountA(P1) = 0 Then
  P1 = P2.Value
End If
Application.EnableEvents = True
End Sub

Faites une sélection multiple (touche Ctrl enfoncée) sur 2 cellules des 2 lignes à traiter.

Edit : salut mapomme

A+

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

Bonjour Job75.
Effectivement, une sélection multiple me paraît mieux. Mais tu ne fais apparemment pas l'échange des 2 C:H ni un MsgBox de confirmation, qui me paraît, là, indispensable. De plus ça devrait aussi pouvoir fonctionner si 1 seule Areas d'exactement 2 lignes.

 

[kinel]

Re : transférer le contenu de plusieurs cellules

bonjour à tous

merci pour toutes ces propositions

je pense opter pour celle ci-dessous mais le seul petit souci c'est qu'en choisissant de ne pas poursuivre il m'ouvre le menu habituel du clic droit. Y aurait il un moyen de ne pas afficher ce menu ?

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If MsgBox("voulez vous poursuivre la procédure ?", _
vbOKCancel + vbInformation, "Changement de chambre") = vbCancel Then Exit Sub
Dim T() As Variant
If NLigEch > 0 Then
If Target.Row <> NLigEch Then
Application.EnableEvents = False
T = Me.[C:H].Rows(NLigEch).Value
Me.[C:H].Rows(NLigEch).Value = Me.[C:H].Rows(Target.Row).Value
Me.[C:H].Rows(Target.Row).Value = T
Application.EnableEvents = True
End If
NLigEch = 0
Else: NLigEch = Target.Row: End If
Cancel = True
End Sub

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re Danreb,

Je ne fais pas l'échange des 2 [C:H] parce que kinel a écrit au post #1 :

je voudrai intégrer une macro qui me permette de transférer le contenu de plusieurs cellules vers d'autres sans modifier le format et seulement si la destination est vide

Une MsgBox dans ce cas est bien inutile : si on se trompe il suffit d'effacer la plage de destination...

A+

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

je pense opter pour celle ci-dessous mais le seul petit souci c'est qu'en choisissant de ne pas poursuivre il m'ouvre le menu habituel du clic droit.

C'était voulu: si on fait un clic droit dans un contexte non adapté à cette interprétation spéciale où si on refusait celle ci, il devait reprendre son sens normal. Voilà pour quoi je n'exécutais pas Cancel = True dans ce cas.

Voir si cette procédure ne serait pas mieux. Sélectionner 2 ligne consécutives ou non mais alors avec touche Ctrl maintenue enfoncée pour la 2ième :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim N As Long, TR(1 To 2) As Range, T() As Variant
Select Case Target.Areas.Count
   Case 1: If Target.Rows.Count <> 2 Then Exit Sub
      For N = 1 To 2: Set TR(N) = Intersect(Me.[C:H], Target.Rows(N).EntireRow): Next N
   Case 2: For N = 1 To 2: If Target.Areas(N).Rows.Count <> 1 Then Exit Sub
      Set TR(N) = Intersect(Me.[C:H], Target.Areas(N).EntireRow): Next N
   Case Else: Exit Sub
   End Select
If MsgBox("Voulez-vous intervertir l'occupation des chambre suivantes :" _
   & vbLf & TR(1).Columns(0) & ": " & TR(1).Columns(3) & " " & TR(1).Columns(2) _
   & vbLf & TR(2).Columns(0) & ": " & TR(2).Columns(3) & " " & TR(2).Columns(2), _
   vbYesNo + vbQuestion, "Sélection spéciale") = vbYes Then
   Application.EnableEvents = False
   T = TR(1).Value: TR(1).Value = TR(2).Value: TR(2).Value = T
   Application.EnableEvents = True: End If
End Sub

 

[kinel]

Re : transférer le contenu de plusieurs cellules

ça y est, je crois avoir un code qui corresponde bien à l'usage recherché

pour job75 : effectivement, dans ma première question j'avais bien spécifié seulement si la destination est vide mais j'ignorait que la magie d'excel et le génie des users de ce forum permettrait l'inversion des chambres
merci encore à tous

Kinel

voici le code que je vais utiliser
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If MsgBox("voulez vous poursuivre la procédure ?", _
vbOKCancel + vbInformation, "Changement de chambre") = vbCancel Then Exit Sub
Dim T() As Variant
If NLigEch > 0 Then
If Target.Row <> NLigEch Then
Application.EnableEvents = False
T = Me.[C:H].Rows(NLigEch).Value
Me.[C:H].Rows(NLigEch).Value = Me.[C:H].Rows(Target.Row).Value
Me.[C:H].Rows(Target.Row).Value = T
Application.EnableEvents = True
End If
NLigEch = 0
Else: NLigEch = Target.Row: End If
Cancel = True
End Sub

 

[Dranreb]

Re : transférer le contenu de plusieurs cellules

le génie

Bof. Je me suis borné à imaginer la vrai finalité du besoin, qui m'est aussitôt apparue évidente…

P.S. Voir quand même ma dernière proposition, issue de l'idée de Job75, et qui à l'avantage de ne pas comporter de situation inachevée.