Emailing out worksheets to different addresses

[lost_in_the_sauce]

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?

 

[Jeffrey Mahoney]

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

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.

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

 

[lost_in_the_sauce]

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

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.

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

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

 

[Jeffrey Mahoney]

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.