Discussion :

[guillaume7684]

Bonjour,

Dans ma macro ci-jointe j'ai un cadre qui est créé avec 2 lignes de texte contenant le nom du classeur et de la feuille.
J'aimerais que les 2 lignes de texte soit en gras et en police 14.
Pourriez-vous m'aider car je n'y arrive pas, j'avoue ce n'est pas mon métier !!!!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
 
Option Explicit
 
Const Dossier_Global = "F:\Prestations"
Sub Enreg_classeur()
 
  Dim Fichier As String, Feuille As String, dlig As Long
 
  Dim Dossier_Clients As String
Dim Feuille_Existe As Boolean
 
 
  Dossier_Clients = Dossier_Global & "\" & [B1]
 
  If Dir(Dossier_Clients, vbDirectory) = "" Then MkDir Dossier_Clients
 
  Fichier = Dossier_Clients & "\" & [B5] & ".xlsx": Feuille = [B6]
 
  If Dir(Fichier) = "" Then
    ' Le fichier n'existe pas => on le crée (1 seule feuille, sur laquelle on est)
    ' -4167 => création d'un nouveau classeur avec une feuille de calcul vierge
    Workbooks.Add -4167: ActiveWorkbook.Author = ""
 
  Else
    ' Le fichier existe => on l'ouvre, puis on essaye d'aller sur la feuille B6 ;
    ' si pas d'erreur : on est dessus ; sinon : on ajoutera 1 feuille en dernier
    Workbooks.Open Fichier
    On Error Resume Next
    Err.Clear
    Worksheets(Feuille).Select
    If Err Then
        Worksheets.Add , Worksheets(Worksheets.Count)
        Feuille_Existe = False
    Else
        Feuille_Existe = True
    End If
 
  End If
  ' Effacement de la liste précédemment copiée (selon filtre) déjà existante ;
  ' ainsi, si la nouvelle liste copiée est moins longue, les lignes en plus
  ' de la précédente liste n'apparaîtront pas
  dlig = [A1].CurrentRegion.Rows.Count
  If dlig > 1 Then Range("A1:F" & dlig).ClearContents
  With ThisWorkbook
    With .Worksheets("Liste")
      .[A1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy [A2]
      Columns("A:C").ColumnWidth = 60
      Columns("D:E").ColumnWidth = 20
      Columns("F:F").ColumnWidth = 40
 
    End With
    With .Worksheets("Prestation")
      ActiveSheet.Name = .[B6]
    End With
  End With
 
 
  Dim Image_Logo As String
  Dim Largeur_Logo As Long
  Dim ShapeLeft As Long
  Dim Image_Client As String
 
Rows(1).Interior.Color = RGB(255, 255, 255)
 
 
    ' PARAMETRE : ******************* HAUTEUR DES LIGNES 2 à X *******************
    ActiveSheet.UsedRange.Rows.RowHeight = 30
    ' PARAMETRE : ******************* HAUTEUR DE LA PREMIERE LIGNE *******************
    Rows(1).RowHeight = 205
 
    Columns("A:A").ColumnWidth = ThisWorkbook.Sheets("Liste").Columns("A:A").ColumnWidth
    Columns("B:B").ColumnWidth = ThisWorkbook.Sheets("Liste").Columns("B:B").ColumnWidth
    Columns("C:C").ColumnWidth = ThisWorkbook.Sheets("Liste").Columns("C:C").ColumnWidth
 
If Feuille_Existe = False Then
    Image_Logo = Dossier_Global & "\Logos\Logo.jpg"
      With ActiveSheet.Pictures.Insert(Image_Logo)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            ' PARAMETRE : ******************* LARGEUR DE "MON LOGO" *******************
            .Width = 200
 
        End With
        .Left = ActiveSheet.Cells(1, 1).Left
        .Top = ActiveSheet.Cells(1, 1).Top
        .Placement = 3
        .PrintObject = True
        End With
 
    Image_Client = Dossier_Global & "\Logos\Logo " & ThisWorkbook.Worksheets("Prestation").[B1] & ".jpg"
      With ActiveSheet.Pictures.Insert(Image_Client)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 200
            ' PARAMETRE : ******************* LARGEUR DU LOGO CLIENT (ALIGNE A DROITE DU TABLEAU) *******************
            Largeur_Logo = .Width
 
        End With
        .Left = ActiveSheet.Cells(1, 7).Left - Largeur_Logo - 1
        .Top = ActiveSheet.Cells(1, 6).Top
        .Placement = 3
        .PrintObject = True
        End With
 
 
 
    ShapeLeft = (ActiveSheet.Columns("A:F").Width / 2) - 100
 
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, ShapeLeft, 18, 230, 72).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Font.Bold.Text = Feuille & vbCrLf & vbCrLf & ThisWorkbook.Sheets("Prestation").[B5]
 
    Selection.ShapeRange(1).TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
    Selection.ShapeRange(1).TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
 
 
    With Selection.ShapeRange(1).TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 10
        .Solid
    End With
 
    With ActiveSheet.PageSetup
            .Orientation = xlLandscape
            .FitToPagesWide = 1
    '        .FitToPagesTall = 0
 
            .Zoom = False
 
    End With
 
 
Else: End If
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Fichier
  Application.DisplayAlerts = True
ActiveSheet.PageSetup.PrintArea = ActiveSheet.Range("A1:F" & ActiveSheet.UsedRange.Rows.Count)
 
End Sub

[kiki29]

Salut, pour cela voir avec Excel et l'enregistreur de macro

[guillaume7684]

Bonjour,

J'ai bien essayé mais je n'y arrive pas car le texte apparait dans un classeur créé par une macro, donc je ne peux pas le faire dans le fichier source.

Merci.

[kiki29]

Salut, et alors, ce code doit être placé à la position idoine dans le classeur concerné

[guillaume7684]

J'ai réussi en ajoutant ce code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
    Selection.ShapeRange(1).TextFrame2.TextRange.Font.Bold = msoTrue
    Selection.ShapeRange(1).TextFrame2.TextRange.Font.Size = 14

Merci quand même.