Emailing out worksheets to different addresses

lost_in_the_sauce

lost_in_the_sauce

Board Regular
Joined
Jan 18, 2021
Messages
128
Office Version
  1. 365
Platform
  1. Windows
I've been tasked with helping automate one of out monthly processes that accounting team takes care of. We receive an excel file with credit card information for different cardholders within the company - I'm helping them automating parsing the charges out to different tabs by cardholder (so each person can code/notate the correct expense account for each charge). Currently they build 40+ individual files and email them individually.

Is there a way w/ VBA that I could have the tabs/sheets all in one workbook, with the affiliated email address in a certain cell, and have Excel/Outlook kick the individual sheets out to the different email addresses in one go?
 
Sort by date Sort by votes
Yes. Do you know VBA well? Anyway, here's a good project to start with.

Here's some code I use to create an email from pre-populated ranges on my Email sheet
VBA Code: 
Sub CreateEmail()

  Dim objOutlook As Object
  Dim objMail As Object
  Dim A As String
  Dim Q As String
  Dim EmailTo As String
  Dim EmailFrom As String
  Dim EmailCC As String
  Dim EmailSubject As String
  Dim EmailBody As String
  Dim OutAccnt As Outlook.account
  Dim xOutMsg As String
  Dim Hrt As String
  Dim PublishPathFile As String
  
  
  EmailTo = Email.Range("EmailTo").Value
  EmailFrom = Email.Range("EmailFrom").Value
  EmailCC = Email.Range("EmailCC").Value
  EmailSubject = Email.Range("EmailSubject").Value
  EmailBody = Email.Range("EmailBody").Value
  PublishPathFile = SETUP.Range("SavedName")

  
  Set objOutlook = CreateObject("Outlook.Application")
  Set objMail = objOutlook.CreateItem(0)
  Set OutAccnt = objOutlook.Session.Accounts.Item("chpCentralServices@BP.com")
  

  xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
  xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
  
               
  With objMail
    
    .BodyFormat = olFormatHTML
    .SendUsingAccount = OutAccnt              'Supposedly allows the correct Signature to be loaded
    .SentOnBehalfOfName = OutAccnt            'Group email account
    .To = EmailTo
    .CC = EmailCC
    '.bcc = "Bla"
    .Subject = EmailSubject
    .Display                   'Instead of .Display, you can use .Send to send the email
    .HTMLBody = xOutMsg & .HTMLBody               'Put this after .Display to save the signature
    .Attachments.Add PublishPathFile, 1
    '.Send                                 or .Save to save a copy in the drafts folder
  End With


  Set objOutlook = Nothing
  Set objMail = Nothing
  


End Sub


Here's some code I use to pull out one sheet from my main workbook, create a new workbook, and move the new sheet that has been valued over to the new WB. I have named ranges on my SETUP sheet that tell the macro where to save the new file and what to name it. You would have to adopt something similar for each of the sheets you want to send.
VBA Code: 
Sub PublishSummary()
  Dim AWB As Workbook
  Dim SumSht As Worksheet
  Dim ASht As Worksheet
  Dim R As Range
  Dim NewWB As Workbook
  Dim NewSht As Worksheet
  Dim AWBName As String
  Dim NewWBName As String
  Dim CompletionPath As String
  Dim ClosureType As String
  Dim LCB As Long
  Dim RCB As Long
  Dim i As Long
  Dim A As String
  Dim TempName As String
  Dim NewName As String
  Dim SetupSht As Worksheet
  
  Set AWB = ThisWorkbook
  Set SetupSht = SETUP
  Set SumSht = SUMMARY
  SumSht.Activate
  NewWBName = SETUP.Range("PublishFileName").Value
  'AWBName = Left(AWBName, InStr(AWBName, ".xls") - 1) & ".xlsx"
  CompletionPath = SETUP.Range("CompletionPath").Value
  If Right(CompletionPath, 1) <> "\" Then CompletionPath = CompletionPath & "\"
  'ClosureType = SumSht.Range("ClosureStatus").Value
  
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  
  SumSht.Copy Before:=SumSht
  Set ASht = ActiveSheet
  Set R = ASht.Range("A1:X1000")
  R.Value = R.Value
  
  Set NewWB = Workbooks.Add                     'Add new WB
  ASht.Copy Before:=NewWB.Sheets(1)             'Copy new summary sheet
  Set NewSht = ActiveSheet
  NewSht.Name = "Summary"
  ASht.Delete                                   'Delete the copied sheet from the main WB
  
  On Error Resume Next
  For i = NewWB.Names.Count To 1 Step -1                'Delete all named ranges
    NewWB.Names(i).Delete
  Next i
  On Error GoTo 0
  
'  LCB = InStr(AWBName, "{")                           'rename the file with either Partial or Full
'  RCB = InStr(AWBName, "}")
'  NewWBName = Left(AWBName, LCB - 1) & ClosureType & Mid(AWBName, RCB + 1, 1000)
  NewWBName = CompletionPath & NewWBName
  A = Dir(NewWBName)
  If Len(A) > 0 Then
    TempName = Left(NewWBName, Len(NewWBName) - 5)
    For i = 2 To 100
      NewName = TempName & "_" & Format(i, "##") & ".xlsx"
      A = Dir(NewName)
      If Len(A) = 0 Then
        NewWBName = NewName
        Exit For
      End If
    Next i
  End If
  SetupSht.Range("SavedName").Value = NewWBName
  NewWB.SaveAs Filename:=NewWBName, FileFormat:=xlOpenXMLWorkbook                   'Save to xlsx
  
    
  Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  
End Sub
 
Upvote 0
Jeffrey Mahoney said:
Yes. Do you know VBA well? Anyway, here's a good project to start with.

Here's some code I use to create an email from pre-populated ranges on my Email sheet
VBA Code: 
Sub CreateEmail()

  Dim objOutlook As Object
  Dim objMail As Object
  Dim A As String
  Dim Q As String
  Dim EmailTo As String
  Dim EmailFrom As String
  Dim EmailCC As String
  Dim EmailSubject As String
  Dim EmailBody As String
  Dim OutAccnt As Outlook.account
  Dim xOutMsg As String
  Dim Hrt As String
  Dim PublishPathFile As String
 
 
  EmailTo = Email.Range("EmailTo").Value
  EmailFrom = Email.Range("EmailFrom").Value
  EmailCC = Email.Range("EmailCC").Value
  EmailSubject = Email.Range("EmailSubject").Value
  EmailBody = Email.Range("EmailBody").Value
  PublishPathFile = SETUP.Range("SavedName")

 
  Set objOutlook = CreateObject("Outlook.Application")
  Set objMail = objOutlook.CreateItem(0)
  Set OutAccnt = objOutlook.Session.Accounts.Item("chpCentralServices@BP.com")
 

  xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
  xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
 
              
  With objMail
   
    .BodyFormat = olFormatHTML
    .SendUsingAccount = OutAccnt              'Supposedly allows the correct Signature to be loaded
    .SentOnBehalfOfName = OutAccnt            'Group email account
    .To = EmailTo
    .CC = EmailCC
    '.bcc = "Bla"
    .Subject = EmailSubject
    .Display                   'Instead of .Display, you can use .Send to send the email
    .HTMLBody = xOutMsg & .HTMLBody               'Put this after .Display to save the signature
    .Attachments.Add PublishPathFile, 1
    '.Send                                 or .Save to save a copy in the drafts folder
  End With


  Set objOutlook = Nothing
  Set objMail = Nothing
 


End Sub


Here's some code I use to pull out one sheet from my main workbook, create a new workbook, and move the new sheet that has been valued over to the new WB. I have named ranges on my SETUP sheet that tell the macro where to save the new file and what to name it. You would have to adopt something similar for each of the sheets you want to send.
VBA Code: 
Sub PublishSummary()
  Dim AWB As Workbook
  Dim SumSht As Worksheet
  Dim ASht As Worksheet
  Dim R As Range
  Dim NewWB As Workbook
  Dim NewSht As Worksheet
  Dim AWBName As String
  Dim NewWBName As String
  Dim CompletionPath As String
  Dim ClosureType As String
  Dim LCB As Long
  Dim RCB As Long
  Dim i As Long
  Dim A As String
  Dim TempName As String
  Dim NewName As String
  Dim SetupSht As Worksheet
 
  Set AWB = ThisWorkbook
  Set SetupSht = SETUP
  Set SumSht = SUMMARY
  SumSht.Activate
  NewWBName = SETUP.Range("PublishFileName").Value
  'AWBName = Left(AWBName, InStr(AWBName, ".xls") - 1) & ".xlsx"
  CompletionPath = SETUP.Range("CompletionPath").Value
  If Right(CompletionPath, 1) <> "\" Then CompletionPath = CompletionPath & "\"
  'ClosureType = SumSht.Range("ClosureStatus").Value
 
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False
  Application.EnableEvents = False
 
  SumSht.Copy Before:=SumSht
  Set ASht = ActiveSheet
  Set R = ASht.Range("A1:X1000")
  R.Value = R.Value
 
  Set NewWB = Workbooks.Add                     'Add new WB
  ASht.Copy Before:=NewWB.Sheets(1)             'Copy new summary sheet
  Set NewSht = ActiveSheet
  NewSht.Name = "Summary"
  ASht.Delete                                   'Delete the copied sheet from the main WB
 
  On Error Resume Next
  For i = NewWB.Names.Count To 1 Step -1                'Delete all named ranges
    NewWB.Names(i).Delete
  Next i
  On Error GoTo 0
 
'  LCB = InStr(AWBName, "{")                           'rename the file with either Partial or Full
'  RCB = InStr(AWBName, "}")
'  NewWBName = Left(AWBName, LCB - 1) & ClosureType & Mid(AWBName, RCB + 1, 1000)
  NewWBName = CompletionPath & NewWBName
  A = Dir(NewWBName)
  If Len(A) > 0 Then
    TempName = Left(NewWBName, Len(NewWBName) - 5)
    For i = 2 To 100
      NewName = TempName & "_" & Format(i, "##") & ".xlsx"
      A = Dir(NewName)
      If Len(A) = 0 Then
        NewWBName = NewName
        Exit For
      End If
    Next i
  End If
  SetupSht.Range("SavedName").Value = NewWBName
  NewWB.SaveAs Filename:=NewWBName, FileFormat:=xlOpenXMLWorkbook                   'Save to xlsx
 
   
  Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = True
  Application.EnableEvents = True
 
End Sub
Click to expand...
I am a VBA neophyte but making this automate would endear me to a lot of people so dammit, we're gonna figure it out
 
Upvote 0
Well, I like that attitude. This is going to take some time. Ask tons of questions, post code. Get a copy of the XL2BB if you don't already.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Send bulk email attachment error
Replies
3
Views
312
JOHATUP
J
A
  • Solved
Copy Entire Workbook, save as sheet name with current date, hide all sheets except one, & attach to email
Replies
2
Views
828
Amo840812
A
lost_in_the_sauce
  • Question Question
Pulling info from multiple tabs - different numbers of rows of data
Replies
0
Views
501
lost_in_the_sauce
lost_in_the_sauce
S
  • Question Question
Can a macro help create a user hierarchy?
Replies
7
Views
811
Akuini
Akuini
G
  • Question Question
Modify Single Email in Outlook Drafts subfolder
Replies
1
Views
454
g_speran
G

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