Concatener en couleur

[ORBAN]

Bonjour à tous,
Savez vous s'il est possible de concatener en couleur ,
Je m'explique:
Dans une cellule de "reception" j'ai concaténer le contenue d'un groupe de céllules!
pour que la lecture soit plus facile j'avais pensé attribuer une couleur a chque mot de chaque cellule pour qu'au final le résultat du "concaténage" (a vérifiier dans le dico!!)😱 soit une suite de mots de couleurs différentes.
A votre avis, je rêve ou c'est possible ?🙁
merci d'avance

 

[ORBAN]

Re : Concatener en couleur

Bonjour et merci PORCINET 😛
Je regarde demain matin et t'informes de l'évolution.
MERCI encore

 

[ORBAN]

Re : Concatener en couleur

Bonjour à TOUS et MERCI PORCINET82.
Je viens de poser ta formule dans mes feuilles.
La démarche est Ok mais j'ai les problèmes suivant:😕
1) le 1er groupe de mot disparaît complètement de la concaténation
2) sur certaine feuille mais pas d'autre la 1ere lettre en couleur arrive au 3 ém ou 4 ém mot. Je te joins un exemple.
Merci d'avance.😉

 

[porcinet82]

Re : Concatener en couleur

Salut Orban,

J'ai apporté une petite modification a la macro car elle ne fonctionnait pas pour tout les cas de figure du premier fichier :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k&, j&, x%, cel$
 
If Not Intersect(Target, Range("B7:K" & Range("A65536").End(xlUp).Row)) Is Nothing Then
    For j = 12 To 23
        cel = cel & Cells(Target.Row, j).Value
    Next j
    With Cells(Target.Row, 1)
        .Font.ColorIndex = 1
        .Font.Bold = False
        .Value = cel
    End With
End If
j = 1
For k = 12 To 21
    If Not Cells(Target.Row, k).Value = "" Then
        With Cells(Target.Row, 1).Characters(Start:=j, Length:=1).Font
            .Color = vbRed
            .Bold = True
        End With
        j = j + 3
    End If
Next k
If Not Cells(Target.Row, 22).Value = "" Then
    With Cells(Target.Row, 1).Characters(Start:=InStr(1, Cells(Target.Row, 1), "/") - 3, Length:=1).Font
        .Color = vbRed
        .Bold = True
    End With
End If
End Sub

Je te laisse tester sur tes autres cas de figure. Si cela ne fonctionne pas, il me faudrait un exemple dans lequel figure le contenu des listes deroulantes afin que je puisse tester directement en changeant les valeurs.

@+

 

[ORBAN]

Re : Concatener en couleur

Merci PORCINET82,
en attendant ta réponse j'ai fais les modifs suivantes sur ta 1ére formule:
If Not Intersect(Target, Range("B7:K" & Range("A65536").End(xlUp).Row)) Is Nothing Then
For j = 12 To 23
cel = cel & Cells(Target.Row, j).Value
Next j
With Cells(Target.Row, 1)
.Font.ColorIndex = 1
.Font.Bold = False
.Value = cel
End With
End If
j = 1
For k = 12 To 21
J'ai remplacé ("B7:K") par ("B7:J")
et
For j= 12 to 23 par For 11 to 23 (J'ai ainsi retrouvé mon 1er mot) idem pour
for k= 12 to 21 par for k= 11 to 21
Qu'en penses tu ?
C'est la 1ére fois que je trouve une modif et qui fonctionne,
Par contre j'ai vu que sur ta deuxiéme formule tu n'avais pas touché à ces éléments ?

Dois-je remettre comme avant ?😱

 

[porcinet82]

Re : Concatener en couleur

re,

Et bien content de voir que tu arrives a comprendre le code et que tu arrives a le bricoler, c'est signe que tu n'attends pas les réponses sans rien faire.
En fait, suivant tes feuilles, il faut que tu joues sur ces paramètres, donc si ca fonctionne tel que tu les as mis, laisse comme ca, par contre inclue également la modif que j'ai apporter au code.

@+

 

[ORBAN]

Re : Concatener en couleur

Je viens d'inserer ton code avec mes modifs, et cela fonctionne sur plusieurs feuilles, je vais poursuivre pour les autres.
Y a t il un moyen simple pour ouvrir tous les codes de toutes les feuilles en même temps ?
Je voudrais enlever l'ancien code pour le remplacer pour ton dernier.
J'ai beaucoup d'onglets et un à un c'est un peu long et fastidieu !
Ceci dit, j'ai avancé grace à toi, et aux ami(e)s du Forum.
Spéciale pensé pour toi et MERCI à tous😉

 

[porcinet82]

Re : Concatener en couleur

Désolé mais là, je crois bien que mes connaissances sont épuisées, je ne vois pas comment faire ce que tu souhaites. Mais peut etre que quelqu'un aura une idée.

@+

 

[_Thierry]

Re : Concatener en couleur

Bonjour Romain, Porcinet, le Forum

Voici de quoi traîter la dernière question.

NB Code à placer dans un Autre Classeur, que celui devant subir le traitement... (Sinon gros risque de plantage d'Excel)

Code de nettoyage :

Sub DeletePrivateSubWorkSheet()
Dim WB As Workbook, WS As Worksheet
Dim CodeM As Object
Dim NomProc As String, NomFeuille As String
Dim DebCode As Integer, LongCode As Integer, VBext_Pk_Proc As Long

On Error GoTo ErrorHandler
Set WB = Workbooks("Erase_Write_VBA.xls") [B][COLOR=green]'NB A Adapter[/COLOR][/B]
NomProc = "Worksheet_SelectionChange"
 
For Each WS In WB.Worksheets
NomFeuille = WS.Name
    On Error Resume Next
        Set CodeM = WB.VBProject.VBComponents(WB.Sheets(NomFeuille).CodeName).CodeModule
          With CodeM
                DebCode = .ProcStartLine(NomProc, VBext_Pk_Proc)
                LongCode = .ProcCountLines(NomProc, VBext_Pk_Proc)
                .DeleteLines DebCode, LongCode
          End With
    
Next WS
Exit Sub
ErrorHandler:
    If Err = 9 Then
        MsgBox "Classeur recherché pas ouvert"
    Else
        MsgBox "Erreur non gérée " & Err.Number & " " & Err.Description
    End If
End Sub

Code de génération :

Sub GeneratePrivateSubWorkSheet()
Dim WB As Workbook, WS As Worksheet
Dim CodeM As Object
Dim NomFeuille As String
Dim x As Integer
 
On Error GoTo ErrorHandler
Set WB = Workbooks("Erase_Write_VBA.xls") [B][COLOR=#008000]'NB A Adapter[/COLOR][/B]

For Each WS In WB.Worksheets
NomFeuille = WS.Name
        Set CodeM = WB.VBProject.VBComponents(WB.Sheets(NomFeuille).CodeName).CodeModule
          With CodeM
                x = .CountOfLines
                .InsertLines x + 1, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
                .InsertLines x + 2, "MsgBox ""Hello XLD"",VBinformation "
                .InsertLines x + 3, "[EMAIL="'@+Thierry"]'@+Thierry[/EMAIL]"
                .InsertLines x + 4, "End Sub"
          End With
Next WS
Exit Sub
ErrorHandler:
    If Err = 9 Then
        MsgBox "Classeur recherché pas ouvert"
    Else
        MsgBox "Erreur non gérée " & Err.Number & " " & Err.Description
    End If
End Sub

Pour les utilisateurs d'Office 2002/2003 avant de pouvoir utiliser ce genre de codes, il faut penser à cocher la case "Faire Confiance au Projet Visual Basic" dans les paramètres de Sécurité comme suit :



Bonne Journée

@+Thierry
​

 

[ORBAN]

Re : Concatener en couleur

Bonjour Thierry et merci
C'est Ok!
Parfait!😛