Help with pasting specific table data in the same format to attach to email

[Callum_97]

Hi,

I'm having an issue with attaching selected cell range to an email with the same formatting (Filters, Column width etc). Please see below:

I want the attachment to look as it does above just for cell ranges that cover my table but it looks like the below once it runs the macro:

I will paste in my VBA script so far any help would be appreciated

Sub DoThingsPls()
Dim newsheet As Worksheet
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim xMailBody As String
Dim dtToday As String

dtToday = Format(Date, "dd_mm_yyyy")
Sheets(dtToday).Range("A1:E100").Copy
Set newsheet = Sheets.Add
ActiveSheet.Paste
Cells.NumberFormat = "General"

On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = "SABAR Escalations " & Format(Now, "dd-mmm-yy")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
xMailBody = "Good morning," & vbNewLine & vbNewLine & _
"Please see attached outstanding escalations, any help with these would be appreciated." & vbNewLine & vbNewLine & _
"Regards" & vbNewLine & _
""
On Error Resume Next
With OutlookMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "SABAR Escalations daily spreadsheet"
.Body = xMailBody
.Attachments.Add ActiveWorkbook.FullName
.Display 'or use .Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub