Mail every worksheet using A1 as address

[sknight22]

Hello
I am using code from the below link to send multiple sheets to email addresses in cell a1.

http://www.rondebruin.nl/win/s1/outlook/amail5.htm

I have hit a snag though. My sheets are made up of filtered pivots and I don’t want the recipient to be able to take the filter off.

Could the code be amended to first copy and paste special the whole sheet then send?

Thanks

Stephen

 

[Norie]

Stephen

That's strange, for one thing the formatting shouldn't be lost in the first place - when you paste special values the formatting should stay intact.

 

[sknight22]

Hello

Yes when I tested it manually it seemed ok.

I’ll try again tomorrow when I’m at work and see if it was just something I was doing wrong.

Thanks

Stephen.

 

[sknight22]

Hi Norie,

I have just tried this again and it does send the time in an odd format (below)

LOADING TIME

0.541666667

0.625

0.666666667

<colgroup><col></colgroup><tbody>
</tbody>

Any ideas why this could be?

Thanks
Stephen

 

[Norie]

Stephen

Rather than an odd format, to me that looks like unformatted times.

If I copy that to Excel and format as Time I get this.

LOADING TIME
13:00:00
15:00:00
16:00:00

So somewhere along the line the formatting is being lost, but I can't see anything in the code that would cause that to happen.

Can you post the code as you currently have it?

 

[sknight22]

Hello,

Yes the code I have is

Option Explicit


Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh 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

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

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")

For Each sh In ThisWorkbook.Worksheets

If sh.Range("A1").Value Like "?*@?*.?*" Then

sh.Copy

Set wb = ActiveWorkbook

'Change all cells in the worksheet to values

With wb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells.PasteSpecial xlPasteFormats
End With

Application.CutCopyMode = False

TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutMail = OutApp.CreateItem(0)

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

On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "TEST"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0

.Close savechanges:=False
End With

Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr

End If

Next sh

Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

 

[Norie]

Stephen

Can you try this?

Goto the code, select this line,

Set wb = ActiveWorkbook

add a breakpoint to it using F9 and then run the code.

When code execution stops return to Excel and have a look at the new workbook that's been created.

Is it formatted correctly?

 

[sknight22]

Hello,

Ok, I have done this. When I ran the code it created a new workbook called Book2 with the time formatted correctly

Thanks
Stephen

 

[Norie]

Stephen

Can you try stepping through the code from that point on with F8 and checking what's actually happening with the new workbook/sheet?

 

[sknight22]

Hi,

Ok i have done that and the format changes from time to the below when i get to

.Cells.PasteSpecial xlPasteFormats

LOADING TIME

0.541666667

0.625

0.666666667

<colgroup><col></colgroup><tbody>
</tbody>

 

[SREEMOORTHYP]

Sub RangeA1AddressedSendMail()
Dim OlApp As Object
Dim OutMail As Object
Dim Tempfile As Workbook
Dim TempFileSheeName As String
Dim MailSentFilePath As String
Dim MasterFils As Workbook


Application.DisplayAlerts = False
Application.ScreenUpdating = False


Workbooks.Open Filename:="D:\TestNewFile.xlsx"
Set MasterFils = ActiveWorkbook


For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Select
TempFileSheeName = ActiveSheet.Name
If Range("A1").Value <> "" Then
MasterFils.Activate
ActiveSheet.Copy
Set Tempfile = ActiveWorkbook
Application.CutCopyMode = False
ActiveSheet.Name = TempFileSheeName
Tempfile.SaveAs Filename:=ThisWorkbook.Path & "" & TempFileSheeName & ".xlsx"
MailSentFilePath = ActiveWorkbook.FullName
Tempfile.Close

Set OlApp = CreateObject("Outlook.Application")
Set OutMail = OlApp.CreateItem(0)

With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = TempFileSheeName
.Body = "Hi Team," & vbNewLine & "Please find the attached " & TempFileSheeName _
& vbNewLine & vbNewLine & "Regards," & vbNewLine & "SreeMoorthy P"
.Attachments.Add (MailSentFilePath)
.Display
'.Send
End With

End If


Next
MasterFils.Close
MsgBox "File has been mail sent done"


Set Tempfile = Nothing
Set MasterFils = Nothing
Set OlApp = Nothing
Set OutMail = Nothing


End Sub