Ajout de texte sans modifier la mise en page existante

Bonjour,

J'en appelle a votre aide sur un sujet dont je ne trouve pas la solution depuis des semaines.

J'aurais besoin d'une macro qui ajoute a une cellule existante la date du jour au format "jj.mois", mais ne modifierai pas la mise en page de la cellule.

Par une macro je cree une cellule au format "jj.mois" puis utilise le code :

Sub Pastenow()

'

Range("A" & "2").Value = "=DAY(TODAY())"

Range("A" & "3").Value = "=Month(TODAY())"

Range("A" & "4") = Range("A" & "2") & "." & Range("A" & "3")

If ActiveCell = "" Then

ActiveCell.FormulaR1C1 = ActiveCell.Formula & Range("A" & "4") & " "

Else

With ActiveCell

.Characters(Len(.Value) + 1).Insert vbCrLf & Range("A" & "4") & " "

End With

End If

Dim rngFrom1 As Range

Dim rngTo As Range

Dim lenFrom1 As Integer

Set rngTo = ActiveCell

lenFrom1 = rngTo.Characters.Count

With ActiveCell.Characters(lenFrom1 - 5, 6).Font

.Name = Cells(4, 1).Characters(1, 6).Font.Name

.Bold = Cells(4, 1).Characters(1, 6).Font.Bold

End With

With ActiveCell.Characters(lenFrom1, 1).Font

.Name = Cells(3, 1).Characters(1, 1).Font.Name

.Bold = Cells(3, 1).Characters(1, 1).Font.Bold

End With

SendKeys "{F2}"

End Sub

Deux problemes se creent :

• Au dessus de 150 caracteres la fonction .insert ne fonctionne plus.
• une fois sur 5 la commande Sendkeys me renvoie a la page d'impression.

Pour info le simple "&" fait perdre la mise en page de la cellule et enregistrer le format de chaque caractere de la cellule initiale prend trop de temps de chargement.

Si quelqu'un a une idee je suis preneur

Merci beaucoup

Jordan

Bonjour jorodi10,

Désolé mais je n'ai pas bien saisir ton problème.

Tu écris

J'aurais besoin d'une macro qui ajoute a une cellule existante la date du jour au format "jj.mois", mais ne modifierai pas la mise en page de la cellule.

• Qu'entends-tu par "mise en page de la cellule"?
• Dans quel cas obtiens-tu plus de 150 caractères lors de l'insert?

Bonjour GVIALLES,

Merci de t'interesser a mon sujet.

Oui mise en page est un mauvais terme, ca serait plutot mis en forme (gras, police, couleur...).

J'ai des cellules qui sont mis a jour chaque semaine sous le format :

01.01 Mise a jour liste

02.01 Demande client

03.01 Validation client

La macro devrait ajouter automatiquement la date du jour en gras mais laisser le reste du texte precedent en sous sa mise en forme initiale.

Lorsque la cellule fait plus de 150 caracteres l'insert ne rajoute rien (limitation connue de cette fonction).

Merci

Jordan

Pour être sûr de bien comprendre, peux-tu envoyer un EXCEL les cellules remplis avec les résultats attendus?

Bonjour,

Pour ne mettre en forme qu'une portion du texte d'une cellule:

    With ActiveCell.Characters(Start:=1, Length:=4).Font
        .Name = "Calibri"
        .FontStyle = "Gras"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

Ici on commence à la première lettre, avec une longueur de 4 lettres à mettre en gras, il suffit de faire pareil avec ta cellule qui contient la date.

En piece jointe le fichier avec la macro.

Le but est d'avoir un raccourci clavier (ici ctrl+w) pour creer la date dans la cellule C5.

Ici la macro marche mais lorsqu'il y a trop de caracteres comme sur C6, il n'y a pas d'insert du texte.

@Ausecours, le probleme est d'ajouter du texte sans modifier la mise en forme existante mais j'utilise deja ton code pour mettre la date en gras

Jordan

OK Jordi10, je regarde ça et te reviens ASAP.

Jordi10,

Un proposition de code :

Sub PastePreserveFormat()
    Dim oCellTopic As Range
    Dim oCellConcatenate As Range
    Dim sConcatenate As String, lPos As Long

    Set oCellTopic = ActiveSheet.Range("B3")
    Set oCellConcatenate = ActiveSheet.Range("C4")

    sConcatenate = oCellConcatenate.Value & vbCrLf & Format(Now(), "DD.M") & Space(1) & oCellTopic.Value
    With oCellConcatenate
        .Value = sConcatenate
        .Font.Bold = False
        lPos = 1
        Do Until lPos = 0
            .Characters(lPos, 5).Font.Bold = True
            lPos = InStr(lPos, .Value, Chr(10))
            If lPos > 0 Then
                lPos = lPos + 1
            End If
        Loop
    End With

    Set oCellTopic = Nothing
    Set oCellConcatenate = Nothing

End Sub

Bonjour GVIALLES,

Wahou cette solution marche parfaitement ! Je n'avais pas pense a utilise le fait qu'il y avait une mise a la ligne a chaque fois entre les dates.

C'est bien trouve.

Merci beaucoup.

Jordi10