Mail every worksheet using A1 as address

S

sknight22

Board Regular
Joined
Feb 16, 2016
Messages
75
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Stephen

Where on the sheets are the pivots located?

Are there multiple pivots on each sheet?
 
Upvote 0
Hi Norie

I basically have a sheet with my raw data. Then a master pivot which I have copied to several sheets in the workbook and filtered by company.

It is just one pivot per sheet

I have the code that will send each sheet to the address in cell a1 in each sheet but I don’t want the person receiving to be able to remove filters and view other company info, so just wondered if it can be adapted to copy and paste special first?

Or something similar

Thank you for reading
 
Last edited:
Upvote 0
I have another workbook that does a similar thing - it takes the pivot in each sheet and saves it as a single workbook in a new folder.

This sheet does copy and paste special before it saves using the below code. I am just not sure where to put it in my other code though?

Any ideas?

'Change all cells in the worksheet to values
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
 
Upvote 0
Norie said:
Stephen

Can you post your current code?
Click to expand...

Hi Yes it is;

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


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
 
Upvote 0
Stephen

This should incorporate the code to copy and paste special values but it's untested right now.

Code: 
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(1).Select
            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
 
Upvote 0
Hello again
"
Thanks this is amazing. I have just tested and it is great. Theres just one thing. I mistakenly thought i needed it to "paste special values" but some of the data is formatted as time so doesn't look right.

Is it possible for it to "Paste special values and source formatting"?

Sorry to be a pain - this is the closest ive ever been to it working 100%

Thank you again for all your help with this

Stephen
 
Upvote 0
Stephen

Off the top of my head, and again untested.
Code: 
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
 
Upvote 0
Hi Norie

Its so close. when i run this code the loading times in the sheet (formatted as time, below in black) are copied over and pasted as the below (in red)
[TABLE="width: 114"]
<colgroup><col></colgroup><tbody>[TR]
[TD]LOADING TIME[/TD]
[/TR]
[TR]
[TD]13:00:00[/TD]
[/TR]
[TR]
[TD]15:00:00[/TD]
[/TR]
[TR]
[TD]16:00:00[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 114"]
<colgroup><col></colgroup><tbody>[TR]
[TD]LOADING TIME[/TD]
[/TR]
[TR]
[TD="align: right"]0.541666667[/TD]
[/TR]
[TR]
[TD="align: right"]0.625[/TD]
[/TR]
[TR]
[TD="align: right"]0.666666667[/TD]
[/TR]
</tbody>[/TABLE]

Any ideas on a fix for this?

Thanks for your time with this


Stephen
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
copy from worksheet and paste to email body with formatting
Replies
3
Views
905
Domenic
D
O
  • Question Question
email macro - RDB code
Replies
0
Views
579
orsm6
O
A
  • Question Question
Help on how to update this code to have it send to recipients in Cell Value
Replies
1
Views
1K
agutosay
A
E
  • Solved
Hiding first column of Email
Replies
3
Views
557
James006
James006
E
  • Question Question
Automatically populate cell after vba email sent
Replies
1
Views
928
eddieum1
E

Forum statistics

Threads
1,223,243
Messages
6,170,967
Members
452,371
Latest member
Frana

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top