Problème macro et de paste sur Excel 365
E
Bonjour,
Sub CreerUnOngletAvecLogoEtSignature()
Dim WsSource As Worksheet, WsNouvelOnglet As Worksheet, WsSignature As Worksheet, WsLogo As Worksheet
Dim OngletName As String
Dim MyLogo As Shape, MySignature As Shape
On Error GoTo Fin
Application.ScreenUpdating = False
With ThisWorkbook
Set WsSource = .Sheets("Feuil1")
Set WsLogo = .Sheets("Logo")
Set WsNouvelOnglet = .Sheets.Add(after:=Sheets(Sheets.Count)) ' Crée un nouvel onglet
End With
With WsLogo
Set MyLogo = .Shapes("Image 1") ' Référence l'image dans la feuille
Set MySignature = .Shapes("Image 2")
End With
With WsNouvelOnglet
OngletName = WsSource.Range("E2")
.Name = OngletName & " " & Format(NumeroOnglet(OngletName), "00") ' Utilise le nom extrait comme nom de l'onglet
.Tab.Color = RGB(0, 255, 0) ' Vert ' Colore l'onglet
End With
MyLogo.Copy ' Copie l'image du logo dans la feuille active (wsNouvelOnglet)
With WsNouvelOnglet ' Colle le logo à la position souhaitée
.Pictures.Paste
With .Shapes(1)
.LockAspectRatio = msoTrue
.Left = 595
.Top = 10
End With
End With
Application.CutCopyMode = False ' Efface le presse-papiers (pour éviter les problèmes)
MySignature.Copy ' Copie l'image de la signature dans la feuille active (wsNouvelOnglet)
With WsNouvelOnglet ' Colle la signature à la position souhaitée
.Pictures.Paste
With .Shapes(2)
.LockAspectRatio = msoTrue
.Left = 70
.Top = 100
End With
End With
Application.CutCopyMode = False
GoTo Fin
Fin:
Set WsSource = Nothing: Set WsNouvelOnglet = Nothing: Set WsLogo = Nothing
Set WsSignature = Nothing: Set MyLogo = Nothing: Set MySignature = Nothing
Application.ScreenUpdating = True
End Sub
Function NumeroOnglet(ByVal NomOnglet As String) As Integer
Dim I As Integer
NumeroOnglet = 1
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, NomOnglet, vbTextCompare) > 0 Then
NumeroOnglet = NumeroOnglet + 1
End If
Next I
End Function
Merci beaucoup, ça fonctionne