Hola!
J´ai essayé de l´integrer a ma macro, mais j´ai pas mal d´erreur. Tu pourrais me dire quoi remplacer please?
Dans ma macro actuelle le fichier est sauvegarder comme Temp, et envoyé puis supprimer:
Sub mail()
'Fonctionne sous excel 2000-2013
ActiveSheet.Name = "Leads del " & ThisWorkbook.Sheets("oxo").Range("c4").Value
Dim i%
For i = 200 To 5 Step -1
If Cells(i, 6).Value <> "RSHOP" Then Rows(i).EntireRow.Delete
Next i
Columns("B:N").Select
Range("N1").Activate
Selection.EntireColumn.Hidden = False
Range("N5").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'LISTING RED'!C[-12]:C[-4],5,0)"
Range("N5").Select
Selection.AutoFill Destination:=Range("N5:N50"), Type:=xlFillDefault
Columns("N:O").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="#n/a", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim S As Shape
Dim strbody As String
Dim ligne1, ligne2, ligne3, ligne4 As String
'Définition des diférentes lignes du corps du message en format HTML
ligne1 = "<font color=#1F5681 Size = 4 >Buenos días " & ThisWorkbook.Sheets("oxo").Range("b8").Value & "<br>" & "<br>"
ligne2 = "<font color=#1F5681 Size = 4 >Os adjunto el fichero Excel con los leads a contactar al día del " & ThisWorkbook.Sheets("OXO").Range("b4").Value & "." & "<br>" & "<br>"
ligne3 = "<font color=#1F5681 Size = 4 >Hoy, hay " & ThisWorkbook.Sheets("oxo").Range("b6").Value & " leads SRC a contactar." & "<br>" & "<br>"
ligne4 = "<font color=#1F5681 Size = 4 >Muchas gracias " & "<br>" & "<br>"
'Intégralité du texte du corps du message
strbody = ligne1 & ligne2 & ligne3 & ligne4
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copie la feuille active comme nouvelle feuille
ActiveSheet.Copy
Set destwb = ActiveWorkbook
'Détermine la version d'excel et l'extension de format
With destwb
If Val(Application.Version) < 17 Then
'Utilisation de excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Utilisation de excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
'Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
'Désactiver fenêtre de compatibilité
Application.DisplayAlerts = False
'Sauvegarde la nouvelle feuille/L'envoie par mail/La supprime
TempFilePath = Environ$("temp") & "\"
TempFileName = ActiveSheet.Name
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
' Suppression de l'image du bouton "MAIL"
If Val(Application.Version) > 17 Then
ActiveSheet.Shapes("Rectangle à coins arrondis 10").Delete
End If
Rows("1:3").Select
Range("A3").Activate
Selection.Delete Shift:=xlUp
Range("B1").Select
ActiveWindow.SmallScroll Down:=-12
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
With destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.display
.To = ThisWorkbook.Sheets("OXO").Range("b9").Value & ";" & ThisWorkbook.Sheets("OXO").Range("b10").Value
.CC = ThisWorkbook.Sheets("OXO").Range("b12").Value & ";" & ThisWorkbook.Sheets("OXO").Range("b13").Value & ";" & ThisWorkbook.Sheets("OXO").Range("b14").Value & ";" & ThisWorkbook.Sheets("OXO").Range("b15").Value
.BCC = ""
.Subject = "Lead para contactar del " & ThisWorkbook.Sheets("OXO").Range("C4").Value
.Attachments.Add destwb.FullName
.htmlbody = strbody & .htmlbody
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Effacer le fichier envoyé
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveSheet.Name = "LEAD PARA CONTACTAR"
End Sub