Microsoft 365 Texte formatage

[Usine à gaz]

Bonjour à toutes et à tous,
Je vous souhaite une belle journée

Je fais appel à vous pour un p'tit coup de pouce codé pour mon code.

Le contexte
Dans le fichier test joint : 2 feuilles
- Feuille_Base............. qui contient les textes d'origine
- Feuille_réception... qui est alimentée au clic dans une cellule (B1 - C1 - D1)
Voici mon besoin :
J'ai besoin que dans la "Feuille_réception", à l'affichage après clic dans l'une des cellules B1 - C1 - D1, que la mise en forme des cellules "Feuille_Base" soient respectées.

J'ai pensé à une solution qui fonctionne
Il suffit de formater les textes dans "Feuille_Base"
et de faire un copier/coller dans " Feuille_réception"

Toutefois, le code devient "répétifif" et très long :

Private Sub Worksheet_SelectionChange(ByVal r As Range)
If Not Intersect(r, Range("b1:f1")) Is Nothing And r.Count = 1 Then
Application.ScreenUpdating = False
Application.EnableEvents = False

    If Not Intersect(r, Range("b1")) Is Nothing Then
    Range("F5:I12").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .MergeCells = False
    End With
    Sheets("Feuille_Base").Range("b1").Copy
    Sheets("Feuille_réception").Select
    Range("F5").Select
    ActiveSheet.Paste
    Range("F5:I12").Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .MergeCells = True
    End With
    End If

    If Not Intersect(r, Range("c1")) Is Nothing Then
    Range("F5:I12").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .MergeCells = False
    End With
    Sheets("Feuille_Base").Range("b2").Copy
    Sheets("Feuille_réception").Select
    Range("F5").Select
    ActiveSheet.Paste
    Range("F5:I12").Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .MergeCells = True
    End With
    End If

    If Not Intersect(r, Range("d1")) Is Nothing Then
    Range("F5:I12").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .MergeCells = False
    End With
    Sheets("Feuille_Base").Range("b3").Copy
    Sheets("Feuille_réception").Select
    Range("F5").Select
    ActiveSheet.Paste
    Range("F5:I12").Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .MergeCells = True
    End With
    End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Ce n'est que pour 3 cellules en "Feuille_Base" et dans le fichier dans lequel je veux l'insérer, il y a environ 45 cellules !

Je pense qu'il est possible de raccourcir le code ... peut-être avec une boucle mais je ne sais pas faire.

Auriez-vous le bon code ?
Je joins le fichier test modifié.
Avec mes remerciements,
Amicalement,
lionel,

 

[Usine à gaz]

Re-Bonjour,
je continue à chercher mais sans succès jusqu'à maintenant

 

[mapomme]

Bonsoir @Usine à gaz ,

En espérant avoir bien compris :

Private Sub Worksheet_SelectionChange(ByVal r As Range)
   If Not Intersect(r, Range("b1:f1")) Is Nothing And r.Count = 1 Then
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Range("F5:I12").UnMerge
      Sheets("Feuille_Base").Range("b" & r.Column - 1).Copy Range("F5")
      Range("F5:I12").Merge
      Application.ScreenUpdating = True: Application.EnableEvents = True
   End If
End Sub

 

[Usine à gaz]

Bonsoir Mapomme,
Merci pour m'avoir répondu.
Super, aux 1ers tests ça fonctionne avec le fichier test
Mais je pense que j'ai oublié une p'tite donnée mais ça ne sera pas (je pense) une grosse modif.
Je reviens dès que je peux
Encore merci
lionel,

 

[Usine à gaz]

Re-Mapomme,

Je reviens avec un nouveau fichier test qui représente exactement mon besoin tel que j'intégrerai ton code si tu acceptes de m'aider encore car je n'arrive pas à le modifier.

Dans ce fichier, j'y ai mis les 36 lignes de textes dans la "Feuille_Base" et j'ai modifiée la "Feuille_réception" telle qu'elle est dans mon classeur.

En textes, j'y ai mis des histoires pour enfants lol (que je n'ai pas eu le temps de lire)

Feuille_Base : les titres en colonne A sont les mêmes que ceux de la "Feuille_réception" de B3 à R8 (cellules cliquées),
exemple :
clic en cellule C3 de la "Feuille_réception"
Le texte de la cellule I8 de la "Feuille_Base" est collé en cel L15 fusionnée de la "Feuille_réception"

les textes doivent toujours s'afficher en "Feuille_réception" cellule L15 fusionnée.
Je joins le nouveau classeur test.

A nouveau un grand merci à toi
Amicalement,
lionel,

 

[mapomme]

Re,

Private Sub Worksheet_SelectionChange(ByVal r As Range)
Dim n&
   If Intersect(r, Range("b3:r8")) Is Nothing Or r.Count <> 1 Then Exit Sub
   If Trim(r) = "" Then Range("L15:r21").Clear: Exit Sub
   Application.ScreenUpdating = False: Application.EnableEvents = False
   On Error Resume Next: n = Application.Match(r.Address(0, 0), Sheets("Feuille_base").Columns(2), 0): On Error GoTo 0
   Range("L15:r21").UnMerge
   If n > 0 Then Sheets("Feuille_Base").Cells(n, "i").Copy Range("L15")
   Range("L15:r21").Merge
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

 

[Usine à gaz]

Re e Re Mapomme,
Super Merci
ça fonctionne du feu de Dieu et ça va m'être super utile.
Je vais tenter de voir comment ça fonctionne car quand j'aurais besoin d'ajouter des titres et textes en "Feuille_Base et d'ajouter des cellules à cliquer en "Feuille_réception", il vaudra mieux que je sache comment faire lol
Merci Mapomme, c'est super,
lionel,

 

[Usine à gaz]

Bonjour Mapomme, à toutes et à tous,
Je vous souhaite une belle journée,
J'ai testé plus "à fond" le code de Mapomme - encore un grand merci
AJOUTS PROCES :

Feuille_Base
1 copie de la dernière ligne sur ligne du dessous
sur la nouvelle ligne
2 donner un nom de titre
3 écrire un texte

Feuille_réception
ajouter une cellule (pour l'exemple) S4

Feuille_Base
écrire S4 en Col B de la nvelle ligne
écrire en Col C l'adresse de la cellule du texte (pour l'exemple) I38

enfin modifier le code de la feuille :
If Intersect(r, Range("b3:r8")) Is Nothing Or r.Count <> 1 Then Exit Sub
en :
If Intersect(r, Range("b3:s8")) Is Nothing Or r.Count <> 1 Then Exit Sub

et c'est bon !
On peut aussi trier les colonnes de la Feuille_Base

Je joins le fichier avec un ajout
Bonne journée,
lionel

 

[Usine à gaz]

Bonjour Mapomme, à toutes et à tous,
ça fonctionne super ... Mais lol, j'en ai une ch'ti p'tite dernière
C'est pas très important mais ce serait tout nickel

Etant un ancien expert-comptable et chef d'entreprise, j'ai pour habitude (seconde nature
peut-être ), de tout vérifier ... et en automatique si possible.

Voilà ce que j'aimerais faire :
J'aurais voulu que soit copiées avec un passage à la ligne suivante (CAR(10)) les cellules colonne A + Colonne I :
Sheets("Feuille_Base").Cells(n, "A"CAR(10) + "i").Copy Range("L15") (ne te moques pas lol)
Pour être certain qu'on est bien sur le bon texte.

N'ayant pas réussi à modifier ton code, j'ai fait comme ceci :
J'ai mi la formule suivant en colonne K "=A1CAR(10)&I1" > recopié jusqu'à ma dernière ligne la formule > copie/valeur en colonne I et effacement de la colonne K

Si tu acceptes la mission (lol ça me dit qq chose ), voudrais-tu inclure cela dans ton code ?
Si cela entraîne trop de modifs, ne t'embête pas, je me débrouille comme énoncé plus haut
Je joins le dernier fichier test,
Que tu le fasses ou non, mes sincères remerciements
C'est déjà génial !
lionel,

 

[mapomme]

Bonsoir @Usine à gaz ,

Faut-il conserver le formatage initial des texte du titre et du corps (couleur police, gras, italique, souligné, taille police) ?

Quelque soit ta réponse, on verra ce soir

 

[Usine à gaz]

Bonsoir Mapomme,
Merci d'être encore là
oui, c'était l'objectif 1er de ce que je veux faire et ce que tu as fait fonctionne super bien.
Si modifier pose un problème de conservation du formatage ... on laisse tomber car cette dernière demande n'est pas bien importante

Pour info, les titres y sont déjà car j'ai appliqué la formule et collé les valeurs.
J'ai conservé les textes sans le titre en colonne I que je pourrai remettre sans souci.
lionel,

 

[job75]

Bojour Lionel, mapomme,

Pourquoi vouloir utiliser CAR(10) ? Il suffit de renseigner la cellule L14 :

Private Sub Worksheet_SelectionChange(ByVal r As Range)
Dim n&
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Range("L14,L15:r21") = "" 'RAZ
    With Sheets("Feuille_Base")
        On Error Resume Next: n = Application.Match(r.Address(0, 0), .Columns(2), 0): On Error GoTo 0
        If n Then
            Range("L14") = .Cells(n, "a")
            Range("L15:r21").UnMerge
            .Cells(n, "i").Copy Range("L15")
            Range("L15:r21").Merge
        End If
    End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Noter que le test initial If Intersect... était tout à fait inutile.

A+

 

[Usine à gaz]

Bonjour Gérard,
Merci d'être là,
Merci pour le classeur codé, ça fonctionne nickel
Bonne fin de journée,
lionel,

 

[mapomme]

@job75, bonsoir

 

[Usine à gaz]

UN super grand merci Mapomme
lionel