Copie Valeur dans un envoi Outlook

Bonjour,

J'ai besoin de faire un copie valeur (supprimer les formules et les liens) des onglets que j'envoie, mais je n'arrive pas à adapter la formule. c'est la partie que j'ai surligné en jaune. Ce n'est pas un TCD donc ça ne fonctionne pas. J'ai essayé avec cette formule, mais du coup ça me laisse les formules et les liens ;(

'Copie valeur et format de la feuille active dans un nouveau classeur

sh.Copy
Set wb = ActiveWorkbook
Voici mon code en entier :

Sub PURGELIST()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Working in Excel 2000-2016

Dim sh, sh1, sh2, sh3 As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFilePath = Environ$("temp") & "\"

'Determine la version Excel et le type de fichier/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set OutApp = CreateObject("Outlook.Application")

'Si l'Username en cellule B1 à une correspondance Username dans l'onglet "Mapping" si non erreur
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "TCD CONSO" And sh.Name <> "DATABASE" And sh.Name <> "Mapping" And sh.Name <> "TEST" And sh.Name <> "Setting" And sh.Name <> "(vide)" _
And sh.Name <> "887" And sh.Name <> "899" And sh.Name <> "847" And sh.Name <> "870" And sh.Name <> "95F" And sh.Name <> "95E" _
And sh.Name <> "95C" And sh.Name <> "DD" And sh.Name <> "AD" And sh.Name <> "CD" And sh.Name <> "EL" And sh.Name <> "FD" And sh.Name <> "M2" Then
For Each sh1 In ThisWorkbook.Worksheets
If sh1.Name <> "TCD CONSO" And sh1.Name <> "DATABASE" And sh1.Name <> "Mapping" And sh1.Name <> "TEST" And sh1.Name <> "Setting" And sh1.Name <> "(vide)" _
And sh1.Name <> "887" And sh1.Name <> "899" And sh1.Name <> "847" And sh1.Name <> "870" And sh1.Name <> "95F" And sh1.Name <> "95E" _
And sh1.Name <> "95C" And sh1.Name <> "DD" And sh1.Name <> "AD" And sh1.Name <> "CD" And sh1.Name <> "EL" And sh1.Name <> "FD" And sh1.Name <> "M2" Then
If Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets("Mapping").Range("A:B"), sh1.Range("J9").Value) = 0 Then
MsgBox sh1.Name & " Username" & " not fill out in mapping tab 1" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If

Next sh1

For Each sh2 In ThisWorkbook.Worksheets
If sh2.Name <> "TCD CONSO" And sh2.Name <> "DATABASE" And sh2.Name <> "Mapping" And sh2.Name <> "TEST" And sh2.Name <> "Setting" And sh2.Name <> "(vide)" _
And sh2.Name <> "887" And sh2.Name <> "899" And sh2.Name <> "847" And sh2.Name <> "870" And sh2.Name <> "95F" And sh2.Name <> "95E" _
And sh2.Name <> "95C" And sh2.Name <> "DD" And sh2.Name <> "AD" And sh2.Name <> "CD" And sh2.Name <> "EL" And sh2.Name <> "FD" And sh2.Name <> "M2" Then
If Application.WorksheetFunction.VLookup(sh2.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:E"), 5, False) Like "" Then
MsgBox sh2.Name & " Email" & " not fill out in mapping tab2" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If
Next sh2

'Si la valeur en cellule B1 à une correspondance mail dans l'onglet "Mapping" si non erreur
For Each sh3 In ThisWorkbook.Worksheets
If sh3.Name <> "TCD CONSO" And sh3.Name <> "DATABASE" And sh3.Name <> "Mapping" And sh3.Name <> "TEST" And sh3.Name <> "Setting" And sh3.Name <> "(vide)" _
And sh3.Name <> "887" And sh3.Name <> "899" And sh3.Name <> "847" And sh3.Name <> "870" And sh3.Name <> "95F" And sh3.Name <> "95E" _
And sh3.Name <> "95C" And sh3.Name <> "DD" And sh3.Name <> "AD" And sh3.Name <> "CD" And sh3.Name <> "EL" And sh3.Name <> "FD" And sh3.Name <> "M2" Then
If Application.WorksheetFunction.VLookup(sh3.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 10, False) Like "" Then
MsgBox sh3.Name & "CHECK" & " not egal to 0" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If

Next sh3

If sh.Range("J9").Value <> "" Then

'Copie valeur et format de la feuille active dans un nouveau classeur

sh.PivotTables(1).TableRange1.Copy

Set Dest = Workbooks.Add(xlWBATWorksheet)

With Dest.Sheets(1)

.Cells(1).PasteSpecial Paste:=8

.Cells(1).PasteSpecial Paste:=xlPasteValues

.Cells(1).PasteSpecial Paste:=xlPasteFormats

.Name = sh.Name

.Cells(1).Select

Application.CutCopyMode = False

End With

Set wb = ActiveWorkbook

'Nom du fichier envoyer

TempFileName = sh.Name & " Purge List " & ThisWorkbook.Sheets("Mapping").Range("A2")

Set OutMail = OutApp.CreateItem(o)

'insère la nouvelle feuille dans le mail

With wb

.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

On Error Resume Next

Set rng = Nothing

On Error Resume Next

'Only the visible cells in the selection

Set rng = ThisWorkbook.Sheets("Mapping").Range("L29").SpecialCells(xlCellTypeVisible)

'You can also use a fixed range if you want

'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If rng Is Nothing Then

MsgBox "The selection is not a range or the sheet is protected" & _

vbNewLine & "please correct and try again.", vbOKOnly

Exit Sub

End If

With Application

.EnableEvents = False

.ScreenUpdating = False

End With

With OutMail

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

'destinataire = recherche v de la cellule J9 de chaque onglet dans mapping

.To = Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 6, False)

.CC = Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 7, False)

.BCC = ""

.Subject = "Purge List " & ThisWorkbook.Sheets("Mapping").Range("A2")

.HTMLBody = "Dear " & _

Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 4, False) & ",<br />" & _

Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 11, False) & _

RangetoHTML(rng)

.Attachments.Add wb.FullName

'Tu peux ajouter un autre fichier comme ci-dessous

'.Attachments.Add ("C:\test.txt")

.Send 'ou utilise .Display

End With

On Error GoTo 0

.Close savechanges:=False

End With

Set OutMail = Nothing

'Efface le fichier du disque dur que vous avez envoyé

Kill TempFilePath & TempFileName & FileExtStr

End If

End If

Next sh

Set OutApp = Nothing

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

'Une boite de dialogue pour confirmer que l'email a bel et bien été envoyé

MsgBox Application.UserName & "," & vbCr & "These sheets were sent by email.", _

vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Mailling "

Application.DisplayAlerts = True

End Sub

Function RangetoHTML(rng As Range)

' Changed by Ron de Bruin 28-Oct-2006

' Working in Office 2000-2016

Dim fso As Object

Dim ts As Object

Dim TempFile As String

Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in

rng.Copy

Set TempWB = Workbooks.Add(1)

With TempWB.Sheets(1)

.Cells(1).PasteSpecial Paste:=8

.Cells(1).PasteSpecial xlPasteValues, , False, False

.Cells(1).PasteSpecial xlPasteFormats, , False, False

.Cells(1).Select

Application.CutCopyMode = False

On Error Resume Next

.DrawingObjects.Visible = True

.DrawingObjects.Delete

On Error GoTo 0

End With

'Publish the sheet to a htm file

With TempWB.PublishObjects.Add( _

SourceType:=xlSourceRange, _

Filename:=TempFile, _

Sheet:=TempWB.Sheets(1).Name, _

Source:=TempWB.Sheets(1).UsedRange.Address, _

HtmlType:=xlHtmlStatic)

.Publish (True)

End With

'Read all data from the htm file into RangetoHTML

Set fso = CreateObject("Scripting.FileSystemObject")

Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)

RangetoHTML = ts.readall

ts.Close

RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _

"align=left x:publishsource=")

'Close TempWB

TempWB.Close savechanges:=False

'Delete the htm file we used in this function

Kill TempFile

Set ts = Nothing

Set fso = Nothing

Set TempWB = Nothing

End Function

Bonjour Jo75 et

Une petite présentation ICI serait la bienvenue

Si vous ne l'avez pas encore fait, je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER]
qui vous aidera dans vos demandes et réponses sur ce forum et notamment :

• Joignez (si possible) un fichier pour augmenter vos chances d'obtenir de l'aide en cliquant sur le bouton Fichier de l'éditeur. Si votre fichier est trop lourd ou contient des données personnelles, créez une version allégée de votre fichier avec juste assez d'informations pour permettre de comprendre votre problème. Dans tous les cas, ne postez JAMAIS de fichiers avec des informations personnelles ou confidentielles (cet utilitaire peut vous aider à les retirer).

• Pour plus de lisibilité, utilisez la fonctionnalité </> pour insérer vos codes VBA (et si possible aussi pour vos formules Excel).

Merci de votre compréhension

Cordialement

D'accord

Je vais en créer un autre alors