Garder style d'écriture dans Macro

Résolu

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention -
gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention - 18 févr. 2011 à 15:38

Bonjour,

J'ai le code ci-dessous qui me sers à copier des informations d'une feuille Excel (Base de données) à un autre (Mail) de façon à ce qu'elles soient Mise en forme différemment (ex: plusieurs cellules regroupées en une) pour ensuite correspondre à un format email.
Ce que je voudrais c'est de garder le style d'écriture italique (par exemple: Gras, Italique, Souligné) de certains mots des cellules de la colonne P de la feuille "Base de données" aux cellules de la colonne L de la feuille "Mail".

Voici le code:

Private Sub Image4_Click()

Dim DernLign As Integer, Lign As Integer

With Sheets("Mail").Select
Range("B3:N3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End With

With Sheets("Base de données")
DernLign = .Cells(65536, 3).End(xlUp).Row
For Lign = 3 To DernLign
Sheets("Mail").Cells(Lign, 2) = .Cells(Lign, 2) & vbLf & .Cells(Lign, 3) & vbLf & .Cells(Lign, 5) & vbLf & .Cells(Lign, 6)
Sheets("Mail").Cells(Lign, 3) = .Cells(Lign, 1) & vbLf & .Cells(Lign, 4) & vbLf & .Cells(Lign, 7)
Sheets("Mail").Cells(Lign, 4) = .Cells(Lign, 8)
Sheets("Mail").Cells(Lign, 5) = .Cells(Lign, 9)
Sheets("Mail").Cells(Lign, 6) = .Cells(Lign, 10)
Sheets("Mail").Cells(Lign, 7) = .Cells(Lign, 11)
Sheets("Mail").Cells(Lign, 8) = .Cells(Lign, 12)
Sheets("Mail").Cells(Lign, 9) = .Cells(Lign, 13)
Sheets("Mail").Cells(Lign, 10) = .Cells(Lign, 14)
Sheets("Mail").Cells(Lign, 11) = .Cells(Lign, 15)
Sheets("Mail").Cells(Lign, 12) = .Cells(Lign, 16)
Sheets("Mail").Cells(Lign, 13) = .Cells(Lign, 17)
Sheets("Mail").Cells(Lign, 14) = .Cells(Lign, 18)
Next Lign
End With

Merci pour votre aide

Afficher la suite

A voir également:

Garder style d'écriture dans Macro
Style word - Guide
Style d'écriture a copier coller - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Ecriture en gras - Guide
Nom pour facebook stylé - Guide

8 réponses

Réponse 1 / 8

lermite222 Messages postés 8724 Date d'inscription Statut Contributeur Dernière intervention 1 191

Bonjour,
Pas tester mais ça devrait aller...

    With Sheets("Base de données")
        DernLign = .Cells(65536, 3).End(xlUp).Row
        For Lign = 3 To DernLign
        Sheets("Mail").Cells(Lign, 2) = .Cells(Lign, 2) & vbLf & .Cells(Lign, 3) & vbLf & .Cells(Lign, 5) & vbLf & .Cells(Lign, 6)
        .Cells(Lign, 3).Copy
        Sheets("Mail").Cells(Lign, 2).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Sheets("Mail").Cells(Lign, 3) = .Cells(Lign, 1) & vbLf & .Cells(Lign, 4) & vbLf & .Cells(Lign, 7)
        .Cells(Lign, 1).Copy
        Sheets("Mail").Cells(Lign, 3).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Sheets("Mail").Range(Cells(Lign, 4), Cells(Lign, 14)).Copy .Cells(Lign, 8)
        Next Lign
    End With

A+

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

Salut lermite222,

désolé de te décevoir mais ça ne fonctionne pas.
Tu m'as écris le code pour les mauvaise colonnes,
c'est cette ligne de code qui m'interresse: Sheets("Mail").Cells(Lign, 12) = .Cells(Lign, 16)

l'autre souci c'est que ça ne transpose pas seulement les mots en Gras de la "Base de données" au "Mail". Tout les mots deviennent Gras!

Saurais tu comment y remédier?

Merci

Réponse 2 / 8

lermite222 Messages postés 8724 Date d'inscription Statut Contributeur Dernière intervention 1 191

Je pense que oui, mais pour ne pas tourner en rond tu devrais mettre un classeur exemple avec une feuille Base et sur une autre feuille le résultat souhaiter.
Tu peu déposer ton classeur sur CiJoint.fr
et mettre le lien sur un poste suivant.

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

voir le post:

https://forums.commentcamarche.net/forum/affich-20659215-fermeture-userform-vba#p20661133

Réponse 3 / 8

lermite222 Messages postés 8724 Date d'inscription Statut Contributeur Dernière intervention 1 191

Je veux bien voir pour t'aider mais le classeur que tu a déposer ne comporte rien qui puisse m'aiguiller.
1°) Les feuilles mentionnées sur le code ci-dessus n'existe pas.
2°) Aucune données à recopier
3°) Aucune donnée recopiée.
Mettre un classeur avec
- une feuille Base de donnée comportant des données (avec mise en forme)
- Une feuille Mail avec les données recopiées et la mise en forme qu'elles doivent avoir ou garder.
Sans ça.. pas moyen de t'aider.
A+

Réponse 4 / 8

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

Salut lermite,

J'avais fais le ménage dans les cellules et changer les noms des feuilles pour garder une certaine confidentialité.
Pour équivalence, les feuilles:
- "Base de donnée" du code ci-dessus sont "Point Ordo-Montage"(FKG1 & FKG2 & PKG) du classeur que j'ai déposé
- "Mail" du code ci-dessus sont "Mail" (FKG1 & FKG2 & PKG) du classeur que j'ai déposé

Pour les données à recopier, il s'agit des cellules de la colonne "Commentaires" des 3 Feuille "Point Ordo Montage"FKG1, FKG2 et PKG qui doivent être recopier dans les 3 feuilles "Mail" respective FKG1, FKG2 et PKG avec le style d'écriture. Actuellement le copier/coller marche grâce au boutons MAIL dans le UF Menu sans garder ce style d'écriture.
Dans le VBA, le code se trouve dans le UF Menu, procédure commencant par "Private Sub Image4_Click()"

voici le fichier avec 2 pbls dans chaque feuille (Point Ordo-Montage):
http://www.cijoint.fr/cjlink.php?file=cj201102/cijlKg3cAu.xls

Fais la manip avec le bouton mail du Menu et tu verras que la zone en gras et celle en italique ne sont pas reprises.

Suis-je assez précis?

Restant à dispo

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

Toujours pas de réponses????

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 8

lermite222 Messages postés 8724 Date d'inscription Statut Contributeur Dernière intervention 1 191

J'aimerais bien répondre mais.... y a un code passe pour le code !!!!!

Réponse 6 / 8

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

Désolé,

Je croyais l'avoir enlevé mais ça ne devait pas être le bon fichier, voic le fichier sans mot de passe:

http://www.cijoint.fr/cjlink.php?file=cj201102/cijU6gzSmh.xls

Merci

Réponse 7 / 8

lermite222 Messages postés 8724 Date d'inscription Statut Contributeur Dernière intervention 1 191

Si j'ai bien compris ??
Pas tester mais ça devrait aller...

    With Sheets("Point Ordo-Montage FKG1")
        DernLign = .Cells(65536, 3).End(xlUp).Row
            For Lign = 3 To DernLign
                Sheets("Mail FKG1").Cells(Lign, 2) = .Cells(Lign, 2) & vbLf & .Cells(Lign, 3) & vbLf & .Cells(Lign, 5) & vbLf & .Cells(Lign, 6)
                Sheets("Mail FKG1").Cells(Lign, 3) = .Cells(Lign, 1) & vbLf & .Cells(Lign, 4) & vbLf & .Cells(Lign, 7)
                Sheets("Mail FKG1").Cells(Lign, 4) = .Cells(Lign, 8)
                Sheets("Mail FKG1").Cells(Lign, 5) = .Cells(Lign, 9)
                Sheets("Mail FKG1").Cells(Lign, 6) = .Cells(Lign, 10)
                Sheets("Mail FKG1").Cells(Lign, 7) = .Cells(Lign, 11)
                Sheets("Mail FKG1").Cells(Lign, 8) = .Cells(Lign, 12)
                Sheets("Mail FKG1").Cells(Lign, 9) = .Cells(Lign, 13)
                Sheets("Mail FKG1").Cells(Lign, 10) = .Cells(Lign, 14)
                Sheets("Mail FKG1").Cells(Lign, 11) = .Cells(Lign, 15)
              '  Sheets("Mail FKG1").Cells(Lign, 12) = .Cells(Lign, 16)
              .Cells(Lign, 16).Copy Sheets("Mail FKG1").Cells(Lign, 12)
                Sheets("Mail FKG1").Cells(Lign, 13) = .Cells(Lign, 17)
                Sheets("Mail FKG1").Cells(Lign, 14) = .Cells(Lign, 18)
            Next Lign
    End With

Exemple à retranscrire sur les autres transfert.
A+

Réponse 8 / 8

gunbafo Messages postés 55 Date d'inscription Statut Membre Dernière intervention 3

Nikel!

Merci lermite. ça fonctionne comme je voulais.

A+

Discussions similaires

Bref. Je cherche la police d'écriture de Bref

Police d'écriture Ricard

Votre réponse

Discussions similaires