Copie Valeur VBA

Bonjour,

J'ai besoin de faire un copie valeur (supprimer les formules et les liens) des onglets que j'envoie (2 premiers onglets dans le fichier), 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 ;(

Sh.copy
Set wb = ActiveWorkbook
' Ma Macro

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
ElseIf Application.WorksheetFunction.VLookup(sh1.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:E"), 5, False) Like "" Then
MsgBox sh1.Name & " Email" & " not fill out in mapping tab2" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
ElseIf Application.WorksheetFunction.VLookup(sh1.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 10, False) Like "" Then
MsgBox sh1.Name & "CHECK" & " not egal to 0" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
Exit Sub
End If
End If
Next sh1
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
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

Bonsoir jo75

C'est mieux mais pas complètement ça

Vous avez ajouté un fichier, mais je vous avais indiqué de mettre le code entre balises avec le bouton

Dernière correction de ma part, la prochaine fois c'est poubelle direct sans autre préavis de ma part

Re ceci dit, voici le code qui devrait faire ce que vous souhaitez :

  Dim Wbk As Workbook
  Sheets(Array("RHQ", "UK")).Copy
  Set Wbk = ActiveWorkbook
  With Wbk.Sheets("RHQ").Cells
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  End With
  With Wbk.Sheets("UK").Cells
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  End With
Set Wbk = Nothing

A+

D'accord je vais essayer de faire plus simple.

Car en fait dans mon fichier il y a bcp plus d'onglet. Là je l'ai simplifié au maximum.