XL 2019 VBA - Colorer selection copie

[Saumon80]

Bonjour,

J'ai un fichier avec plusieurs colonnes.

Je souhaite simplement colorer la selection que je copie en couleur et je souhaiterait que chaque selection ai une couleur differente.

Je souhaiterais egalement que la selection copie reste coloree .

Merci pour votre aide car je suis vraiment novice avec VBA.

Cordialement

 

[Dranreb]

Je n'ai pour ma part rien considéré du coté Copier car ce qui est souhaité n'est pas clair du tout.
On ne sait si c'est la cellule qui doit être copiée ou le texte qu'elle affiche, à destination d'une application n'ayant rien à voir avec Excel.
Pour ce dernier cas le plus simple c'est d'utiliser un MSForms.DataObject. Mais il n'est pas très fiable et cesse souvent subitement d'être opérationnel. C'est pourquoi je remplace petit à petit dans touts mes classeurs son utilisation par un module MPressePapier contenant ce code complètement imbitable mais qui marche toujours, au moins :

Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Public Property Let PressePapier(ByVal sUniText As String)
   Dim iStrPtr As Long
   Dim iLen As Long
   Dim iLock As Long
   OpenClipboard 0&
   EmptyClipboard
   iLen = LenB(sUniText) + 2&
   iStrPtr = GlobalAlloc(&H42&, iLen)
   iLock = GlobalLock(iStrPtr)
   lstrcpy iLock, StrPtr(sUniText)
   GlobalUnlock iStrPtr
   SetClipboardData &HD&, iStrPtr
   CloseClipboard
   UfmMsg.Dit PressePapier, "Copié :"
   End Property
Public Property Get PressePapier() As String
   Dim iStrPtr As Long
   Dim iLen As Long
   Dim iLock As Long
   Dim sUniText As String
   OpenClipboard 0&
   If IsClipboardFormatAvailable(&HD&) Then
       iStrPtr = GetClipboardData(&HD&)
       If iStrPtr Then
           iLock = GlobalLock(iStrPtr)
           iLen = GlobalSize(iStrPtr)
           sUniText = String$(iLen \ 2& - 1&, vbNullChar)
           lstrcpy StrPtr(sUniText), iLock
           GlobalUnlock iStrPtr
       End If
       PressePapier = sUniText
   End If
   CloseClipboard
   End Property

 

[Saumon80]

Bonjour.
Un changement de teinte devrait suffire alors. Mais pourquoi aléatoire ? Un roulement sur 12 couleurs par exemple ne serait-il pas mieux ?
Comme ça par exemple :

Option Explicit
Private NuCoul As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Clr As New Couleur
   Clr.EAF 500, (NuCoul + 0.5) / 2
   Target.Interior.Color = Clr.C: Target.Font.Color = Clr.CP
   NuCoul = NuCoul Mod 12 + 1
   End Sub

Oui 12 couleurs serait parfait , en effet l'aleatoire n'est pas forcement le mieux dans ce cas.

Merci beaucoup Dranreb

 

[Dranreb]

Je vous en prie.

 

[Saumon80]

Merci Fanch et Dranreb.
En fait je selectionne des celulles, par exemple A1 : B4 , je copie la selection et souhaite colorer cette selection que j'ai copie.

Dans l'absolu colorer ce qui a ete selectionne pourait aussi marcher si c'est complexe de colorer la copie.

 

[Dranreb]

Toujours aussi incompréhensible …
Pour copier la plage sélectionnée il suffit dans ma procédure d'ajouter un Target.Copy. Mais je doute sérieusement de sa pertinence par rapport au mystérieux collage que vous voulez en faire après …
Je ne vois pas de solution pour le collage avec ces couleurs dans une autre application. Dans une autre plage Excel en revanche ça ne devrait pas poser trop de problème.

 

[Saumon80]

Oui desole c est dur a expliquer,

Je ne veux pas coller ces couleurs dans une autre application.
Je veux juste selectioner une plage Excel et la colorer ; donc soit colorer la selection ou ce qui a ete copie , mais je veux uniquement colorer une plage excel. Le collage n'entre pas en compte du coup;

 

[Dranreb]

Vous avez donc à présent tout ce qu'il vous faut, n'est-ce pas.

 

[fanch55]

Si à chaque fois que vous sélectionnez des cellules dans votre feuille, il faut les colorer ,
vous allez avoir un beau sapin de Noël ...

 

[fanch55]

Pour vous faire avancer toutefois,
testez ce code à placer dans celui de la feuille
faites un clic droit sur les cellules sélectionnées
et choisissez "Copier en colorant" ....

Un inconvénient toutefois, ce que vous allez coller
aura la même couleur que celle qui aura été calculée si c'est un document Office ...
Dans ce cas, faites un coller sans format ...

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim Rbar    As CommandBar
Const Cb = "RightClick"

    Cancel = True
    On Error Resume Next: CommandBars(Cb).Delete: On Error GoTo 0
    Set Rbar = CommandBars.Add(Cb, msoBarPopup, , True)
    With Rbar
        With .Controls.Add(msoControlButton, , , .Controls.Count + 1, True)
            .Caption = "Copier en colorant"
            .FaceId = 19
            .OnAction = Me.CodeName & ".CopyWithCol"
        End With
        With .Controls.Add(msoControlPopup, , , .Controls.Count + 1, True)
             .Caption = "Autres Choix"
             FromBar = IIf(Target.ListObject Is Nothing, "Cell", "List Range Popup")
            For Each CBar In Application.CommandBars(FromBar).Controls
                .Controls.Add CBar.Type, CBar.ID, , , True
            Next
         End With
        .ShowPopup
        .Delete
    End With
End Sub
Sub CopyWithCol()
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Interior.Color = RGB(Int(256 * Rnd), Int(256 * Rnd), Int(256 * Rnd))
End Sub

 

[Saumon80]

Bonjour Fanch ,

Merci infiniment! Oui en effet il y aura de la couleur mais ce ne sera pas a sauvegarder fort heuresement

Le code marche quand je le lance mais quand je clic droit je nai pas l'option copier en colorant qui s'affiche?

 

[fanch55]

Le code doit être mis dans la feuille, pas dans un module .

 

[Saumon80]

Ah oui en effet cela marche maintenant ! Merci infiniment!