Bonjour le fil,
J'ai un sousis de code depuis que je suis passé en excel 2010 le fichier se boque régulierement,
Image en C44 ne se copie pas automatiquement je suis obligé d'ouvrir chaque onglet et même la il bloque de temps en temps je repasse par l'onglet modèle.
Pouvez-vous m'aider
ci-joint le code qui a été elaboré en grande parti par le fil
Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim s As Shape
With Sheets("Modèle") 'à adapter
If Sh.Name Like "*x*" Then
For Each s In Sh.Shapes
If s.TopLeftCell.Address = "$C$44" Then s.Delete
Next
For Each s In .Shapes
If s.TopLeftCell.Address = "$C$44" Then s.Copy: Sh.Paste Sh.[C44]
Next
End If
End With
Dim l As Shape, T As Object, F As Object, CF, CL
For Each l In Feuil54.Shapes
If l.Name Like "*Rectang*" Then
Set T = l.TextFrame
Set F = T.Characters.Font
CF = l.Fill.ForeColor.RGB 'remplissage
CL = l.Line.ForeColor.RGB 'bordure
Exit For
End If
Next
For Each l In Sh.Shapes
If l.Name Like "*Rectang*" Then
With l.TextFrame
If Left(.Characters.Text, 1) = " " Then Exit For 'évite toute modification
.Characters.Text = T.Characters.Text
'.HorizontalAlignment = T.HorizontalAlignment
'.VerticalAlignment = T.VerticalAlignment
'.ReadingOrder = T.ReadingOrder
'.Orientation = T.Orientation
'.AutoSize = T.AutoSize
With .Characters.Font
.Name = F.Name
.FontStyle = F.FontStyle
.Size = F.Size
.Strikethrough = F.Strikethrough
.Superscript = F.Superscript
.Subscript = F.Subscript
.OutlineFont = F.OutlineFont
.Shadow = F.Shadow
.Underline = F.Underline
.Color = F.Color
End With
End With
l.Fill.ForeColor.RGB = CF
l.Line.ForeColor.RGB = CL
Exit For
End If
Next
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
If Target.Address = "$B$8" Then Sh.Name = Target
End Sub
J'ai un sousis de code depuis que je suis passé en excel 2010 le fichier se boque régulierement,
Image en C44 ne se copie pas automatiquement je suis obligé d'ouvrir chaque onglet et même la il bloque de temps en temps je repasse par l'onglet modèle.
Pouvez-vous m'aider
ci-joint le code qui a été elaboré en grande parti par le fil
Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim s As Shape
With Sheets("Modèle") 'à adapter
If Sh.Name Like "*x*" Then
For Each s In Sh.Shapes
If s.TopLeftCell.Address = "$C$44" Then s.Delete
Next
For Each s In .Shapes
If s.TopLeftCell.Address = "$C$44" Then s.Copy: Sh.Paste Sh.[C44]
Next
End If
End With
Dim l As Shape, T As Object, F As Object, CF, CL
For Each l In Feuil54.Shapes
If l.Name Like "*Rectang*" Then
Set T = l.TextFrame
Set F = T.Characters.Font
CF = l.Fill.ForeColor.RGB 'remplissage
CL = l.Line.ForeColor.RGB 'bordure
Exit For
End If
Next
For Each l In Sh.Shapes
If l.Name Like "*Rectang*" Then
With l.TextFrame
If Left(.Characters.Text, 1) = " " Then Exit For 'évite toute modification
.Characters.Text = T.Characters.Text
'.HorizontalAlignment = T.HorizontalAlignment
'.VerticalAlignment = T.VerticalAlignment
'.ReadingOrder = T.ReadingOrder
'.Orientation = T.Orientation
'.AutoSize = T.AutoSize
With .Characters.Font
.Name = F.Name
.FontStyle = F.FontStyle
.Size = F.Size
.Strikethrough = F.Strikethrough
.Superscript = F.Superscript
.Subscript = F.Subscript
.OutlineFont = F.OutlineFont
.Shadow = F.Shadow
.Underline = F.Underline
.Color = F.Color
End With
End With
l.Fill.ForeColor.RGB = CF
l.Line.ForeColor.RGB = CL
Exit For
End If
Next
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
If Target.Address = "$B$8" Then Sh.Name = Target
End Sub