VBA to send mail based on sheet name

Question

I need to send email from excel to individual persons based on the sheet names. If sheet1 name is raju, it must be sent as an attachment to [email protected], sheet2 name is babu, it must be sent as an attachment to [email protected]

Im trying to write a code but stuck in one line where we specify recipient name. attaching the code below.

Sub Mail_Every_Worksheet()
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String
  Dim xFileFormatNum As Long
  Dim xTempFilePath As String
  Dim xFileName As String
  Dim xOlApp As Object
  Dim xMailObj As Object
  Dim subj As String
  Dim body As String
  subj = InputBox("enter subject")
  body = InputBox("enter body")
  Dim CurrDate As String
CurrDate = Format(Date, "MM-DD-YY")
  On Error Resume Next
  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With
  xTempFilePath = Environ$("temp") & "\"
  If Val(Application.Version) < 12 Then
    xFileExt = ".xls": xFileFormatNum = -4143
  Else
    xFileExt = ".xlsm": xFileFormatNum = 52
  End If
  Set xOlApp = CreateObject("Outlook.Application")
  For Each xWs In ThisWorkbook.Worksheets
    If xWs.Name <> "Sheet1" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " " & CurrDate
      Set xMailObj = xOlApp.CreateItem(0)
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
        'specify the CC, BCC, Subject, Body below
        
            .To = xWs.Sheets(i).Name & "@gmail.com"
            .CC = ""
            .BCC = ""
            .Subject = subj
            .body = body
            .Attachments.Add xWb.FullName
            .Display
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
  Set xOlApp = Nothing
  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

the only error i get is on this line

.To = xWs.Sheets(i).Name & "@gmail.com"

can someone help me how to fix this error Thanks in advance.

Answer 1

There is no need to use the Sheets property to get the Worksheet.Name property value. You already deal with a Worksheet instance in the loop, so you just need to retrieve the Name property.

Dim xWs As Worksheet
...
For Each xWs In ThisWorkbook.Worksheets
  ...
  .To = xWs.Name & "@gmail.com"

Be aware, the recommended way of setting recipients for the email is to using the Recipients.Add method which creates a new recipient in the Recipients collection. Then you need to call the Resolve method which attempts to resolve a Recipient object against the Address Book. For example:

 Set myRecipient = MyItem.Recipients.Add("Eugene Astafiev")
 myRecipient.Resolve 
 If myRecipient.Resolved Then 
   myItem.Subject = "Test task" 
   myItem.Display 
 End If 

Read more about that in the article which I wrote for the technical blog - How To: Fill TO,CC and BCC fields in Outlook programmatically.