Ecrire avec mise en forme

Le 11/11/2017 à 18:50

bonjour, j'ai deux cellules Excel exemple a70 et a1

Je veux que ce que j'écrit dans a70 s'écrive aussi en même temps dans a1. Ex : 10:00 - rendez vous dentiste

par conséquent, j'ai entré dans la cellule a1, =a70.

Cependant j'aimerais que dans a1, la mise en forme de a70 soit gardé. ex: 10:00 serait en caractère gras et rendez vous dentiste en couleur rouge.

Comment puis-je faire pour avoir la même mise en forme dans les deux cellule?

Merci

Dany

Le 11/11/2017 à 19:00

Bonjour

Un essai à tester. Te convient-il ?

Bye !

33classeur1-v1.xlsm (27.83 Ko)
Le 11/11/2017 à 19:07

oui c'est très bien mais comment vous avez fait, car je dois appliquer le même procédé à une trentaine de cellule différente.

Merci beaucoup

Dany

Le 11/11/2017 à 19:42

Bonjour danyboy117,

Fais Alt F11 pour voir le code VBA de gmb, puis pour revenir sur Excel.

Le code VBA n'est pas dans un module classique tel que par exemple Module1 ; il est dans le code de Feuil1

car c'est une procédure événementielle qui doit être utilisée : quand tu changes la valeur de la cellule A70

et que tu valides (appui sur la touche Entrée), ça copie cette valeur en A1 avec le format.

Faire la même chose pour plusieurs cellules est moins évident, et il faudrait que tu donnes la liste complète

des cellules à copier, et pour chaque, dans quelle cellule doit se faire la copie ; je te laisse voir la suite avec

gmb ; bonne chance !

Cordialement

Le 11/11/2017 à 19:50

Salut DanyBoy,

Salut l'équipe,

une façon de faire où tu ne dois t'occuper que d'écrire ton RDV sans te tracasser de mise en forme.

Tu écris en-dessous du cadre, ta prose se recopie dans celui-ci avec ta mise en forme.

Seules obligations (dans l'état actuel de la macro) :

  • bien séparer heure et objet par " - " (espace tiret espace) ;
  • se contenter d'un objet après cette séparation.
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tCel
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    iRow = IIf(Range("A1").End(xlDown).Row > 19, 1, Range("A1").End(xlDown).Row)
    Range("A" & iRow + 1) = Target
    tCel = Split(Target, " - ")
    For x = 0 To UBound(tCel)
        iLen = Len(tCel(x))
        iStart = IIf(x = 0, 1, iStop + 4)
        iStop = iStop + iLen
        If x = 0 Then
            Target.Characters(iStart, iLen).Font.Bold = True
            Range("A" & iRow + 1).Characters(iStart, iLen).Font.Bold = True
        Else
            Target.Characters(iStart, iLen).Font.Color = RGB(255, 0, 0)
            Range("A" & iRow + 1).Characters(iStart, iLen).Font.Color = RGB(255, 0, 0)
        End If
    Next
End If
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub

Le code se trouve dans le module de la feuille1.

A+

26miseenforme.xlsm (14.82 Ko)
Le 11/11/2017 à 21:27

Bonjour a tous, je ne m'y connais pas énormément en Excel encore. voici le document sur lequel je travail. C'est pour une programmation d'activité pour le mois. Voila le dernier tableau du document est le mois au complet et les autre tableau au dessus sont a la semaine. le calendrier du mois est séparé en trois cellule par jour car à la semaine c'est en am, pm et soirée.

Mon but est d'écrire la programmation du mois complet dans le calendrier du mois et que ensuite tout soit retranscrit dans ceux de la semaine avec la même mise en forme.

Voila mon document ca risque d'être plus simple pour vous de voir se que je veux.

Merci

https://drive.google.com/file/d/1q_8xk8HEtnDR9WgOKpJ1ySoChKxOmC6k/view?usp=sharing

Le 12/11/2017 à 00:20

Désolé mais, pour ma part, je ne sais travailler que sur des fichiers Excel en .xlsx ou .xlsm...

Bye !

Le 12/11/2017 à 02:20

Oui ça fonctionne il suffit de le télécharger dans l'onglet en haut à droite

Merci

Le 12/11/2017 à 09:56

Bonjour

Nouvelle version :

https://www.cjoint.com/c/GKmi3j3C18b

Bye !

Le 12/11/2017 à 15:48

Bonjour, j'ai reçu votre version mais je ne crois pas que ca fonctionne car ma mise en forme ne change pas dans les cellules. Y a t'il une formule que je peux entrer dans chaque cellule que je veux qui soient répliqué ex: rejoindre a69 a a5 et a70 et a6 etc pour rejoindre la calendrier du mois au calendrier hebdomadaire.

MERCI

pardon, merci ca fonctionne, les macros n'étaient pas activés

Le 12/11/2017 à 16:06

C'est curieux, car sur mon PC ça marche. Quand tu valides par exemple de contenu de la cellule B85, celui-ci se reporte en B57 avec le format ce la cellule.

Et sans rien faire d'autre que valider.

Bye !

capture
Le 12/11/2017 à 16:08

maintenant j'aime comprendre les chose donc si c'est possible pour vous de m'expliquer comment pouvons nous faire cette commande dans n'importe quelle autre document. Je comprend vite dans la vie donc j'aimerais connaitre cette merveilleuse fonction

Merci encore

Le 12/11/2017 à 16:31
danyboy117 a écrit :

j'aimerais connaitre cette merveilleuse fonction

En fait, ce n’est pas une fonction qui fait ça, c’est une macro.

Tu peux la voir en tapant simultanément sur les touches Alt et F11.

Le ‘’hic’’, c’est qu’elle est spécialement adaptée à tes deux tableaux et à ta feuille de calcul.

Pour obtenir le même résultat sur une autre feuille avec d’autres tableaux, il faut refaire une autre macro semblable.

Bye !

Le 12/11/2017 à 17:27

je vois que votre macro est celle ci:

Option Explicit

Dim plage As Range, i&, j&, d&

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If ActiveSheet.Range("A4") = "AM" Then

Application.EnableEvents = False

Application.ScreenUpdating = False

Set plage = Range("A69")

For i = 69 To 85 Step 4

For j = 1 To 7

Set plage = Union(plage, Cells(i, j), Cells(i + 1, j), Cells(i + 2, j))

Next j

Next i

If Not Intersect(Target, plage) Is Nothing Then

For i = 69 To 85 Step 4

If Target.Row = i Then d = 877: Exit For

If Target.Row = i + 1 Then d = 882: Exit For

If Target.Row = i + 2 Then d = 887: Exit For

Next i

Target.Copy

Cells((13 * Target.Row - d) / 4, Target.Column).PasteSpecial xlPasteAll

End If

End If

Target.Select

Application.CutCopyMode = False

Application.Application.EnableEvents = True

End Sub

Sub Evenement()

Application.EnableEvents = True

End Sub

si je la copie dans d'autre fichier, y a t'il des parties que je ne touche pas, quelles sont celles que je modifie si je veux l'adapter a un autre tableau par exemple?

Merci

Le 12/11/2017 à 18:37
danyboy117 a écrit :

quelles sont celles que je modifie si je veux l'adapter a un autre tableau par exemple?

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If ActiveSheet.Range("A4") = "AM" Then 'Pour ne s'intéresser qu'aux feuilles qui ont AM en cellule A4

Application.EnableEvents = False

Application.ScreenUpdating = False

Set plage = Range("A69") 'Première cellule pour laquelle la macro doit se déclencher

For i = 69 To 85 Step 4 'Première et dernière ligne pour laquelle la macro doit se déclencher

For j = 1 To 7 'Pour des tableaux à 7 colonnes

Set plage = Union(plage, Cells(i, j), Cells(i + 1, j), Cells(i + 2, j))

Next j

Next i

If Not Intersect(Target, plage) Is Nothing Then

For i =69 To 85 Step 4

If Target.Row = i Then d = 877: Exit For

If Target.Row = i + 1 Then d = 882: Exit For

If Target.Row = i + 2 Then d = 887: Exit For

Next i

Target.Copy

Cells((13 * Target.Row - d) / 4, Target.Column).PasteSpecial xlPasteAll

End If

End If

Target.Select

Application.CutCopyMode = False

Application.Application.EnableEvents = True

End Sub

Le 12/11/2017 à 18:47

Excellent merci beaucoup je vais tenter de jouer avec ca pour en apprendre plus. vous êtes un génie!!!

Le 12/11/2017 à 19:17

Salut DanyBoy, gmb,

@gmb ou à tout autre crack : peux-tu me dire ce qui cloche dans ce code, stp ?

L'idée : chercher dans le bas du tableau la date correspondant à celle du tableau supérieur à laquelle on s'apprête à écrire l'agenda et en récupérer l'adresse en [H1] avant traitement de la mise en forme.

[H1] = ""
iRow = Target.Row
iCol = Target.Column
iMod = Target.Row Mod 13
iRowE = Range("A" & Rows.Count).End(xlUp).Row
'
If iRow = 1 Then Exit Sub
On Error Resume Next
If (iMod = 5 Or iMod = 7 Or iMod = 9) And Cells(iRow - 1, 1) = Switch(iMod = 5, "AM", iMod = 7, "PM", iMod = 9, "Soirée") Then
    sData = Format(CDate(Cells(iRow - (Switch(iMod = 5, 2, iMod = 7, 4, iMod = 9, 6)), Target.Column)), "dd/mmmm")
    MsgBox sData & "  " & iRow & "  " & iRowE
    Set rCel = Range("A" & iRow & ":G" & iRowE).Find(what:=sData, lookat:=xlWhole, LookIn:=xlValues)
    [H1] = rCel.Offset(Switch(iMod = 5, 1, iMod = 7, 2, iMod = 9, 3), 0).Address
End If
On Error GoTo 0

J'ai lu plein d'articles partout : rien ne fonctionne! Je deviens enragé!

sData = String à laquelle je donne le format exact de la date affichée que je recherche ensuite avec FIND... que dalle!

Si tu peux m'expliquer comment chercher cela avec FIND, je ne te remercierai jamais assez!

A+

Le 13/11/2017 à 00:10
curulis57 a écrit :

@gmb ou à tout autre crack

Grosse erreur ! Je ne suis pas un crack. La preuve : je ne sais pas apporter de réponse à ta question.

Désolé !

Bye !

Le 13/11/2017 à 09:22

Bonjour danyboy117,

Je te propose le fichier Excel ci-dessous, qui est une reprise modifiée de la solution de gmb ; tu verras

entre autres que j'ai mis en constante la 1ère ligne et la dernière ligne ➯ à adapter à un seul endroit.

Merci de me donner ton avis.

Cordialement

Le 13/11/2017 à 21:16

Salut DanyBoy,

Salut gmb, dhany

ma façon de voir les choses ...

Deux macros à coller dans 'THISWORKBOOK' pour agir sur toutes les feuilles... en espérant qu'elles soient toutes de structure identique, du moins pour le tableau HAUT.

La construction particulière de ce tableau (lignes vides) rend plutôt hasardeuse ce genre de programmation. Aussi, DanyBoy, assure-toi que toutes tes feuilles respectent bien la même structure que "NOVEMBRE/2017" que tu nous as envoyée.

En effet, la recherche de la case correspondante dans le tableau BAS se fait à partir de la reconstruction de la formule y figurant, seul moyen facile que j'ai trouvé pour cette opération.

Le texte doit être écrit dans le tableau HAUT.

La mise en forme est celle décrite dans ton premier post :

  • les heures en noir, gras 10:00 ;
  • l'objet en rouge.

Quelques conditions strictes pour que ça fonctionne sans anicroche :

  • la séparation entre heures et minutes = ":" = 1 deux-points
  • la séparation entre heure et objet = " - " = espace tiret espace
  • la fin de l'objet = "." = 1 point

Pour créer des nouvelles lignes, mais tu dois le savoir : ALT+ENTER

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'
Dim tCells, tCel
'
If [H1] = "" Then Exit Sub
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
Target.Font.Color = RGB(0, 0, 0)
Range([H1]) = Target
tCells = Split(Target, ".")
For y = 0 To UBound(tCells)
    tCel = Split(tCells(y), " - ")
    iStep = IIf(y = 0, 1, iLenT + 2)
    iLenT = iLenT + Len(tCells(y)) + 1
    For x = 0 To UBound(tCel)
        iLen = IIf(x = 0, IIf(y = 0, Len(tCel(x)), Len(tCel(x)) - 1), Len(tCel(x)))
        iStart = IIf(x = 0, iStep, iStop + 4)
        iStop = iStart + iLen - 1
        '
        Target.Characters(iStart, iLen).Font.Bold = IIf(x = 0, True, False)
        Target.Characters(iStart, iLen).Font.Color = IIf(x = 0, RGB(0, 0, 0), RGB(255, 0, 0))
        Range([H1]).Characters(iStart, iLen).Font.Bold = IIf(x = 0, True, False)
        Range([H1]).Characters(iStart, iLen).Font.Color = IIf(x = 0, RGB(0, 0, 0), RGB(255, 0, 0))
    Next
Next
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'
Dim rCel As Range
Dim sData1 As String, sData2 As String
'
[H1] = ""
iRow = Target.Row
iCol = Target.Column
iMod = Target.Row Mod 13
iRowE = Range("A" & Rows.Count).End(xlUp).Row
'
If iRow = 1 Then Exit Sub
On Error Resume Next
If (iMod = 5 Or iMod = 7 Or iMod = 9) And Cells(iRow - 1, 1) = Switch(iMod = 5, "AM", iMod = 7, "PM", iMod = 9, "Soirée") Then
    iData = DateDiff("d", CDate(Range("A3").Value), CDate(Cells(iRow - (Switch(iMod = 5, 2, iMod = 7, 4, iMod = 9, 6)), Target.Column)))
    iRowT = iRow - Switch(iMod = 5, 2, iMod = 7, 4, iMod = 9, 6)
    sCol = Split(Columns(IIf(iCol = 1, 7, iCol - 1)).Address(ColumnAbsolute:=False), ":")(1)
    'Construction de la formule (tableau bas)
    sData1 = IIf(iData = 0, "=A3", "=(" & sCol & 68 + (Int(iRowT / 13) * 4) & "+1)")
    sData2 = IIf(iData = 0, "=A3", "=" & sCol & 68 + (Int(iRowT / 13) * 4) & "+1")
    'recherche de la formule (avec ou sans parenthèses)
    Set rCel = Range("A" & iRow & ":G" & iRowE).Find(what:=sData1, lookat:=xlWhole, LookIn:=xlFormulas)
    If rCel Is Nothing Then Set rCel = Range("A" & iRow & ":G" & iRowE).Find(what:=sData2, lookat:=xlWhole, LookIn:=xlFormulas)
    [H1] = rCel.Offset(Switch(iMod = 5, 1, iMod = 7, 2, iMod = 9, 3), 0).Address
End If
On Error GoTo 0
'
End Sub

Sans doute y a-t-il encore moyen de jouer avec les couleurs mais à chaque jour suffit sa peine!

A+

Rechercher des sujets similaires à "ecrire mise forme"