Copier coller des cellules visibles excel dans email

Public Sub Test_AMX()

Dim wbSource, wbFichierUsager As Workbook
Dim strFileName As String
Dim intChoice As Integer   'Déclarer les variables de base


Set wbFichierUsager = ThisWorkbook
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False 'on indique que nous ne voulons qu’un seul fichier
intChoice = Application.FileDialog(msoFileDialogOpen).Show 'On affiche l’écran de dialogue de MS Office
If intChoice <> 0 Then 'On s’assure que la personne a fait un choix
strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1) 'On récupère le nom complet du fichier
Workbooks.Open strFileName


Else 'Sinon, on arrête tout en notifiant l’usager

MsgBox "La procédure est annulée car aucun fichier n’a été entré. Merci de recommencer et de choisir le fichier AMEX" 'S’il n’y a pas de fichier, on quitte sans rien faire
Exit Sub

End If
            
' Ouverture fichier Associés
    Workbooks.Open Filename:="C:\Users\nelly\Desktop\Listing .xlsx"
    
    Set wbSource = ActiveWorkbook 'definir comme fichier source à fermer apres le copier coller
    ' Coper les données dans le fichier AMEX
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows( _
        "American .xls" _
        ).Activate
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Range("A1").Select
  
wbSource.Close SaveChanges:=False 'Application comme fichier source à fermer apres le copier coller

' CopierColler_Infos Macro

    Sheets("Rapport Détaillé").Select
    Range("H8:M8").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Sheets("Statistique Factures").Select
    Range("I10").Select
    ActiveSheet.Paste
    
    Range("O10").Select
    
    Sheets("Rapport Détaillé").Select
    
    Range("Q8:Y8").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Sheets("Statistique Factures").Select
    ActiveSheet.Paste
    Range("O10").Select
    ActiveSheet.Paste
    
    
    Range("I11").Select
    
' Reperage Macro
'

'
    Sheets("Rapport Détaillé").Select
    Range("G6").Select
    Application.CutCopyMode = False
    
    ActiveCell.FormulaR1C1 = "1"
    Range("H6").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("I6").Select
    ActiveCell.FormulaR1C1 = "3"
    Range("G6:I6").Select
    Selection.AutoFill Destination:=Range("G6:AM6"), Type:=xlFillDefault
    Range("G6:AM6").Select
    
    Range("AM6").Select
    
    Range("H6:M6").Select
    Selection.Copy
    
    Sheets("Statistique Factures").Select
    Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("O9").Select
    Sheets("Rapport Détaillé").Select
    
    Range("Q6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Statistique Factures").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("I11").Select

' Fill_Infos Macro

    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(RC2,'Rapport Détaillé'!R8C7:R853C39,'Statistique Factures'!R9C,0)"
    Range("I11").Select
    Selection.AutoFill Destination:=Range("I11:W11"), Type:=xlFillDefault
    Range("I11:W11").Select
    
    
    'Format date courte invoice date
    
    Range("I11:J11").Select
    Selection.NumberFormat = "m/d/yyyy"
    
    
    'Format date courte travel date
    
    Range("R11:S11").Select
    Selection.NumberFormat = "m/d/yyyy"
    
    Range("I11").Select
    
' Etalage_Formule Macro
'

'
    Range("I11").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFill Destination:=Range("I11:W370")
    

' Matchingg Macro

    ' VlookUp Manager
    Range("X11").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC3,Sheet2!C9:C11,2,0)"
    
    ' VlookUp Email
    Range("Y11").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC3,Sheet2!C9:C11,3,0)"
    
    'Extension formule
    Range("X11:Y11").Select
    Selection.AutoFill Destination:=Range("X11:Y370")
    Range("X11:Y370").Select
    
    Range("X10").Select

' Naming Macro

    ' Renomme cellule manager
    Range("X10").Select
    ActiveCell.FormulaR1C1 = "Manager"
    
    ' Renomme cellule email
    Range("Y10").Select
    ActiveCell.FormulaR1C1 = "Email"
    
    ' Renomme feuille
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "BDD ASSOCIES"
    
    Sheets("Statistique Factures").Select


' Filtering Macro
    
    Range("B10").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    
    Selection.Copy
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Selection.AutoFilter
    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Columns("A:X").EntireColumn.AutoFit
    
Range("C:G").EntireColumn.Hidden = True

' Fine_tunning Macro
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 8367104
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Color = -16711681
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True
    Range("A1").Select
    Selection.End(xlToRight).Select
    Range("X2").Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Columns("Q:R").Select
    Selection.NumberFormat = "m/d/yyyy"
    
    Columns("H:I").Select
    Selection.NumberFormat = "m/d/yyyy"
    
    Range("W1").Select
'-----------------------------------------------------------------------------------------
Dim Liste_Flitre_W, N, Nb
    
    Application.ScreenUpdating = False
    
    'Creation table flitre colonne W
    Call Liste_Infos_sans_doublon(Liste_Flitre_W)
 
    Nb = UBound(Liste_Flitre_W)
    'si entete colonne commence a 1 sinon a 0
    For N = 1 To Nb
        ' Appliquer filtre
        Worksheets("Sheet1").ShowAllData
        ActiveSheet.Range("$A$1:$X$361").AutoFilter Field:=23, Criteria1:=Liste_Flitre_W(N)
'----------------------------------------------------------------------------------------------

' Formule subbtotal de la cellule

    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-22]:C[-18])"
    
    ' Mise en format nombre
    
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    Selection.NumberFormat = "_-* #,##0.0 $_-;-* #,##0.0 $_-;_-* ""-""?? $_-;_-@_-"
    Selection.NumberFormat = "_-* #,##0 $_-;-* #,##0 $_-;_-* ""-""?? $_-;_-@_-"
    Selection.Font.Bold = True
    
    ' Mise en format couleur
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
   

'Envoidu_Mail_Outlook()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim Rng As Range
    
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    
    Set Rng = Nothing
    On Error Resume Next
    
    Set Rng = Range("A1:W361")
    On Error GoTo 0
    If Rng Is Nothing Then
        MsgBox "The selection is not valid please make sure it is " & _
                        vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set Sourcewb = ActiveWorkbook
    
        
    'Copie de la plage de cellules dans un nouveau classeur
    Set Destwb = Workbooks.Add
    
    'copy avec format
    Sourcewb.Sheets("sheet1").Range("A1:W361").Copy Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count)
    
    'Ajustement colonne
    Destwb.ActiveSheet.Cells.EntireColumn.AutoFit
    
    'sauvegarde du nouveau fichier pour joindre dans le mail
    TempFilePath = Environ$("temp") & "\" 'repertoire du fichier
    TempFileName = "Validation déplacements AMEX " & Format(Now, "dd-mmm-yy h-mm-ss") & Sourcewb.Name  'Nom du fichier avec date
    FileExtStr = ".xlsx": FileFormatNum = 51 'extension du fichier en XLS
    
    
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 'sauvegarde du fichier sous
        .Close SaveChanges:=False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
  

'corps du message si besoin
   
    
    With OutMail
    .To = ThisWorkbook.Sheets("Sheet1").Range("Z1").Value  'destinataire(s) A MODIFIER
    .CC = ""  ' copie
    .Subject = "Validation déplacement de ton équipe" ' Sujet
    
    .HTMLBody = "Bonjour ," & _
    vbNewLine & "Tu trouveras ci-dessous les qui s'élévent à" & " " & Range("Y1") & "€" & ". Voici le détail :" & RangetoHTML(Rng)
    .Attachments.Add TempFilePath & TempFileName & FileExtStr
    .Display 'OU send pour envoyer
    
    End With
    
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006 SUITE DE LA MACRO PUIS RETOUR A ATTACEMENTS
' Modified by f894009

    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

'
Sub Liste_Infos_sans_doublon(TMP)
    Dim Dico_Data As Object, Plage, x
    
    With Worksheets("sheet1")
        Set Dico_Data = CreateObject("Scripting.Dictionary")
        derlig = .Range("W" & Rows.Count).End(xlUp).Row   'derniere cellule non vide colonne A
        Plage = .Range("W1:W" & derlig)                               'mise en memoire
        'boucle sur plage
        For x = 1 To UBound(Plage, 1)
            Dico_Data(Plage(x, 1)) = ""
        Next x
    End With
    'transfert infos en tableau
    TMP = Dico_Data.Keys 'Table sans doublon
End Sub