Emailing Active Sheet with Address Lookup

[chefdt]

I am using the following code to email an active sheet one at a time. I'd like to kick it up a notch. Can someone help me.

I'd like to use a VBA routine to cycle through each sheet in a workbook and email the sheet to the recipient found in A2. From there I would like to find the email address of the name listed in A2 by referencing a separate workbook of names and email addresses listed simply as Names, addresses (A:B) respectively.

Here is the code that works....

Sub Email_Sheet()


Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String

'Turn off screen updating
Application.ScreenUpdating = False

'Copy the active worksheet and save to a temporary workbook
ActiveSheet.Copy
Set LWorkbook = ActiveWorkbook

'Create a temporary file in your current directory that uses the name
' of the sheet as the filename
LFileName = LWorkbook.Worksheets(1).Name
On Error Resume Next
'Delete the file if it already exists
Kill LFileName
On Error GoTo 0
'Save temporary file
LWorkbook.SaveAs FileName:=LFileName

'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)

'Set mail attributes (uncomment lines to enter attributes)
' In this example, only the attachment is being added to the mail message
With oMail
'.To = "user@yahoo.com"
.Subject = "THIS IS A TEST"
'.body = "This is the body of the message." & vbCrLf & vbCrLf & _
'"Attached is the file"
.Attachments.Add LWorkbook.FullName
.Display
End With

'Delete the temporary file and close temporary Workbook
LWorkbook.ChangeFileAccess Mode:=xlReadOnly
Kill LWorkbook.FullName
LWorkbook.Close SaveChanges:=False

'Turn back on screen updating
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing

End Sub


Thanks,
DALE

 

[Perpa]

I am using the following code to email an active sheet one at a time. I'd like to kick it up a notch. Can someone help me.

I'd like to use a VBA routine to cycle through each sheet in a workbook and email the sheet to the recipient found in A2. From there I would like to find the email address of the name listed in A2 by referencing a separate workbook of names and email addresses listed simply as Names, addresses (A:B) respectively.

Here is the code that works....

Sub Email_Sheet()


Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String

'Turn off screen updating
Application.ScreenUpdating = False

'Copy the active worksheet and save to a temporary workbook
ActiveSheet.Copy
Set LWorkbook = ActiveWorkbook

'Create a temporary file in your current directory that uses the name
' of the sheet as the filename
LFileName = LWorkbook.Worksheets(1).Name
On Error Resume Next
'Delete the file if it already exists
Kill LFileName
On Error GoTo 0
'Save temporary file
LWorkbook.SaveAs FileName:=LFileName

'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)

'Set mail attributes (uncomment lines to enter attributes)
' In this example, only the attachment is being added to the mail message
With oMail
'.To = "user@yahoo.com"
.Subject = "THIS IS A TEST"
'.body = "This is the body of the message." & vbCrLf & vbCrLf & _
'"Attached is the file"
.Attachments.Add LWorkbook.FullName
.Display
End With

'Delete the temporary file and close temporary Workbook
LWorkbook.ChangeFileAccess Mode:=xlReadOnly
Kill LWorkbook.FullName
LWorkbook.Close SaveChanges:=False

'Turn back on screen updating
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing

End Sub


Thanks,
DALE

Dale,

Use 'VLOOKUP' to get the 'Email Address' on the sheet where the Names and corresponding Email
Addresses reside in columns A and B respectively.
Select a cell where the name you want will be entered. On my sheet that was G4. The file name was
"Send List Addresses.xls"

Enter the following formula in cell G5: =VLOOKUP(G4,A2:B5,2,FALSE). You will need to adjust the range 'A2:B5'
to suit your data...IMPORTANT! This is an array formula and must be entered with 'Ctrl+Shift+Enter'.

Then with the file opened that has the sheets you want to send, put the following code in a standard
code module:

Sub CopyData()
    'This macro looks up the email address in another workbook using a person's NAME in cell A2
    ' of each sheet, then sends each worksheet to the corresponding EMAIL ADDRESS
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Worksheet
    Dim strSavePath As String
    
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    strSavePath = Cells(3, 2)                    'Saves the Path only in cell B3, Change this to suit your needs
    
    Set wbSource = ActiveWorkbook
    
    For Each sht In wbSource.Sheets
        sht.Activate
        [COLOR="#FF0000"]Cells(4, 2) = strSavePath & sht.Name & ".xlsx"   'Filename for each sheet, change as necessary[/COLOR]
        colAname = Cells(2, 1)       'This is cell A2 where you said you stored the name to lookup
        sht.Copy
        [COLOR="#FF0000"]Cells(3, 2) = strSavePath[/COLOR]
        Set wbDest = ActiveWorkbook
        [COLOR="#FF0000"]wbDest.SaveAs Cells(4, 2)    'strSavePath & sht.Name[/COLOR]
        wbDest.Close savechanges:=False 'Remove this if you don't want each book closed after saving.
        
[COLOR="#FF0000"]        Windows("Send List Addresses.xls").Activate     'This file must be opened for the macro to work
        Cells(4, 7) = colAname        'This is cell G4              Change the filename to suit your data
        EmailAddr = Cells(5, 7)        'This is cell G5[/COLOR]
        
        wbSource.Activate
        With sht
            [COLOR="#FF0000"].Cells(2, 3) = EmailAddr   'This should be a cell out of the Used Range on the sheet you are sending[/COLOR]
            Call Email_Sheet              'This could be your macro using Outlook
        End With

    Next sht
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler: 'Just in case something hideous happens
    MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
    
End Sub
[Code/]

I don't have Outlook installed so I used Gmail
To Email  using Gmail:
The cells referenced in red are from the file and the worksheets your are sending.
I stored the same information in the same cells on each sheet.
You can use your code that uses Outlook, but you will need to change the code lines of the '.To=' 
and 'Attachments:=' lines thereof to match.

[Code]
Sub Email_Sheet()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    Dim PDFfileName As String

    'Windows("Send Each Worksheet.xls").Activate    'This is the filename with sheets to be sent

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Update
    End With

    strbody = "Automated email test" & vbNewLine & vbNewLine & _
              "Email from Different Workbook" & vbNewLine & vbNewLine & _
              "Dale"

    With iMsg
        Set .Configuration = iConf
        [COLOR="#FF0000"].To = Cells(2, 3)     'This is cell C2 where I put the EmailAddr from the above macro[/COLOR]
        .CC = ""
        .BCC = ""
        .From = "username@gmail.com"
        .Subject = " Email Test"
        .TextBody = strbody
       [COLOR="#FF0000"] .AddAttachment Cells(4, 2)      'This cell B4 where I put the complete path and filename of the attachment[/COLOR]        .Send
    End With

End Sub
[Code/]

Hope this helps!
Perpa

 

[Perpa]

Dale,

Use 'VLOOKUP' to get the 'Email Address' on the sheet where the Names and corresponding Email
Addresses reside in columns A and B respectively.
Select a cell where the name you want will be entered. On my sheet that was G4. The file name was
"Send List Addresses.xls"

Enter the following formula in cell G5: =VLOOKUP(G4,A2:B5,2,FALSE). You will need to adjust the range 'A2:B5'
to suit your data...IMPORTANT! This is an array formula and must be entered with 'Ctrl+Shift+Enter'.

Then with the file opened that has the sheets you want to send, put the following code in a standard
code module:

Sub CopyData()
    'This macro looks up the email address in another workbook using a person's NAME in cell A2
    ' of each sheet, then sends each worksheet to the corresponding EMAIL ADDRESS
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Worksheet
    Dim strSavePath As String
    
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    strSavePath = Cells(3, 2)                    'Saves the Path only in cell B3, Change this to suit your needs
    
    Set wbSource = ActiveWorkbook
    
    For Each sht In wbSource.Sheets
        sht.Activate
        [COLOR="#FF0000"]Cells(4, 2) = strSavePath & sht.Name & ".xlsx"   'Filename for each sheet, change as necessary[/COLOR]
        colAname = Cells(2, 1)       'This is cell A2 where you said you stored the name to lookup
        sht.Copy
        [COLOR="#FF0000"]Cells(3, 2) = strSavePath[/COLOR]
        Set wbDest = ActiveWorkbook
        [COLOR="#FF0000"]wbDest.SaveAs Cells(4, 2)    'strSavePath & sht.Name[/COLOR]
        wbDest.Close savechanges:=False 'Remove this if you don't want each book closed after saving.
        
[COLOR="#FF0000"]        Windows("Send List Addresses.xls").Activate     'This file must be opened for the macro to work
        Cells(4, 7) = colAname        'This is cell G4              Change the filename to suit your data
        EmailAddr = Cells(5, 7)        'This is cell G5[/COLOR]
        
        wbSource.Activate
        With sht
            [COLOR="#FF0000"].Cells(2, 3) = EmailAddr   'This should be a cell out of the Used Range on the sheet you are sending[/COLOR]
            Call Email_Sheet              'This could be your macro using Outlook
        End With

    Next sht
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler: 'Just in case something hideous happens
    MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
    
End Sub
[Code/]

I don't have Outlook installed so I used Gmail
To Email  using Gmail:
The cells referenced in red are from the file and the worksheets your are sending.
I stored the same information in the same cells on each sheet.
You can use your code that uses Outlook, but you will need to change the code lines of the '.To=' 
and 'Attachments:=' lines thereof to match.

[Code]
Sub Email_Sheet()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    Dim PDFfileName As String

    'Windows("Send Each Worksheet.xls").Activate    'This is the filename with sheets to be sent

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Update
    End With

    strbody = "Automated email test" & vbNewLine & vbNewLine & _
              "Email from Different Workbook" & vbNewLine & vbNewLine & _
              "Dale"

    With iMsg
        Set .Configuration = iConf
        [COLOR="#FF0000"].To = Cells(2, 3)     'This is cell C2 where I put the EmailAddr from the above macro[/COLOR]
        .CC = ""
        .BCC = ""
        .From = "username@gmail.com"
        .Subject = " Email Test"
        .TextBody = strbody
       [COLOR="#FF0000"] .AddAttachment Cells(4, 2)      'This cell B4 where I put the complete path and filename of the attachment[/COLOR]        .Send
    End With

End Sub
[Code/]

Hope this helps!
Perpa[/QUOTE]

Dale,
I forgot to include one formula I placed on each sheet in cell B3. You might use the following in place of the line shown:
[Code]
    'strSavePath = Cells(3, 2)                    'Saves the Path only in cell B3, Change this to suit your needs
   '**************
    strSavePath=application.LEFT(CELL("Filename",A1),application.SEARCH("[",CELL("Filename",A1),1)-1)
    cells(3,2) =strSavePath
   '**************
    Set wbSource = A
[Code/]

Cheers...Perpa

 

[Perpa]

Dale,
I forgot to include one formula I placed on each sheet in cell B3. You might use the following in place of the line shown:

    'strSavePath = Cells(3, 2)                    'Saves the Path only in cell B3, Change this to suit your needs
   '**************
    strSavePath=application.LEFT(CELL("Filename",A1),application.SEARCH("[",CELL("Filename",A1),1)-1)
    cells(3,2) =strSavePath
   '**************
    Set wbSource = A
[Code/]

Cheers...Perpa[/QUOTE]



Dale,
You can just  put this fFormula  in B3 as I did on each sheet to be emailed:
[Code]
=LEFT(CELL("Filename",A1),SEARCH("[",CELL("Filename",A1),1)-1)
[Code]

OR...

You can put the 'Path' )without the filemname in cell B3 of each sheet.
Sorry if there was confusion...I didn't check the 'Application' stuff in my pervious post.
Happy computing!
Perpa