E-Mailing sheets from a workbook

[Javi]

<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>Hello everyone,
<o> </o>
Thanks for taking the time to look into my question!
<o> </o>
The below code works well for e-mailing sheet to different e-mail addresses that are identified in the code. As well as e-mailing multiple sheets for a particular e-mail address.
<o> </o>
My issue is the e-mail addresses have to be maintained in the code I would like to change this to refer to a located on a sheet “email”.
<o> </o>
The code would check column “C1:C100” if “yes” then it would use the address in column “D” and send sheets identify in (“E:Z”).

Thanks!!
<o> </o>
<o>

Excel Workbook
	A	B	C	D	E	F	G	H	I
1	Branch	Name	Send	E-Mail	Sheet	Sheet	Sheet	Sheet	Sheet
2	2563	Jim Smith	Yes	Jim.Smith@email.com	866
3	2365	David Jones	Yes	David.Jones@email.com	875	866	864
4	2561	Jack Black	Yes	Jack.Black@email.com	864
5	5694	Steve Myer	Yes	Steve.Myer@email.com	855	822	821	833
6	6895	Tom Sung	No	Tom.Sung@email.com	842
7	5696	Sam Dell	Yes	Sam.Dell@email.com	857
Sheet1

</o>
<o></o>
<o>

<o:p> </o:p>
<o:p> </o:p>
Sub Multiple_Emails_and_Sheets()
' Multiple_emails_and_Sheets Macro
  [COLOR=#00b050]'This is used for the branches one sheet with multiple e-mails.<o:p></o:p>[/COLOR]
        ThisWorkbook.Sheets("866").Copy
                    Application.DisplayAlerts = False
                    With ActiveWorkbook
                        [COLOR=#00b050]'Enter E-mail address below<o:p></o:p>[/COLOR]
       .SendMail Array (“[EMAIL="Jim.Smith@email.com"]Jim.Smith@email.com[/EMAIL]”)
       "866 This is the Subject line"
                    .Close SaveChanges:=False
End With
   
   [COLOR=#00b050]'This is used for the branches one sheet with multiple e-mails.<o:p></o:p>[/COLOR]
        ThisWorkbook.Sheets("864").Copy
                    Application.DisplayAlerts = False
                    With ActiveWorkbook
                        [COLOR=#00b050]'Enter E-mail address below<o:p></o:p>[/COLOR]
        .SendMail Array("Jack.Black@email.com"), _
        " 864 This is the Subject line"
                    .Close SaveChanges:=False
End With
  [COLOR=#00b050]'This is for the RM's multiple e-mails and multiple sheets<o:p></o:p>[/COLOR]
        ThisWorkbook.Sheets(Array("855", "822",”821”,”833”)).Copy
                    Application.DisplayAlerts = False
                    With ActiveWorkbook
                            [COLOR=#00b050]'Enter E-mail address below<o:p></o:p>[/COLOR]
          .SendMail Array("Steve.Myer@email.com", "[EMAIL="fj450614@yahoo.com"]fj450614@yahoo.com[/EMAIL]"), _
          " 855 & 822 & 821 & 833 This is the Subject line"
                    .Close SaveChanges:=False
End With
End Sub

</o>

 

[Biz]

Create a loop thru email address.

Biz

 

[Javi]

Thank you for the reply,

I do have the below code with many thanks to the board members that works similar to what I'm looking for however I do not have expertise to combining with the original code I posted.

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p> </o:p>
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close SaveChanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
<o:p> </o:p>
Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    If Sheets("Main Sheet").Range("D37").Value Like "?*@?*.?*" And _
       LCase(Sheets("Main Sheet").Range("C37").Value) = "yes" Then
 
       Sheets("Main Sheet").Unprotect
    
       Set rng = Nothing
       On Error Resume Next
       ' Only send the visible cells in the selection.
        ' Set rng = Selection.SpecialCells(xlCellTypeVisible)
       ' You can also use a range with the following statement.
       Set rng = Sheets("Main Sheet").Range("T1:X35").SpecialCells(xlCellTypeVisible)
       On Error GoTo 0
    
       If rng Is Nothing Then
           MsgBox "The selection is not a range or the sheet is protected. " & _
                  vbNewLine & "Please correct and try again.", vbOKOnly
           Exit Sub
       End If
    
       With Application
           .EnableEvents = False
           .ScreenUpdating = False
       End With
<o:p> </o:p>
 
       Set OutApp = CreateObject("Outlook.Application")
       Set OutMail = OutApp.CreateItem(0)
    
       On Error Resume Next
       With OutMail
           
           .To = ThisWorkbook.Sheets("Main Sheet").Range("D37").Value
           .CC = ""
           .BCC = ""
           .Subject = "NFL Pick Your Loser Status"
           .HTMLBody = RangetoHTML(rng)
           ' In place of the following statement, you can use ".Display" to
            .display 'the e-mail message.
           '.Send
       End With
       On Error GoTo 0
    
       With Application
           .EnableEvents = True
           .ScreenUpdating = True
       End With
    
       Set OutMail = Nothing
       Set OutApp = Nothing
      ' ActiveSheet.Unprotect
       Sheets("Main Sheet").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
           , AllowSorting:=True, AllowFiltering:=True
 
    Else
        'MsgBox "No in C37"
    End If
 
End Sub

 

[Javi]

bump

 

[daverunt]

Hi,

I've done the part for creating variables/arrays from the complete worksheet content. It will create workbooks for all 'Yes's in column C with sheet numbers found in E to Z.

It could be adapted for selecting a row to send only 1 mail to 1 person in the list.

You will need to add the bit for handling the copied workbooks and mailing them. Some of the mail parameters are in various places in the code.

The difficult part for me was creating an array of worksheets.
I have taken the row number and the content of each cell in that row is added to build an array including empty cells. (I left it that way in case the sheet numbers weren't contiguous across the row E to Z)

The array contains numbers and need to be converted to strings to be used as worksheet names.

Then all blanks are stripped out of the array. (Thanks to a post in 2009 by xld).

I have done this in three stages as it's my first plug with arrays.
If anyone can do it in shorter code please feel free to post.

Hope it helps you on your way. Check the sheet name in red.

Sub Mail_Content()
Dim myarray As Variant
Dim NewArr()
 
ThisWorkbook.Activate
For Each C In Worksheets[COLOR=red]("Sheet2").[/COLOR]Range("C2:C100").Cells
        Num = C.Row ' gets row number from row 2 onward
        If C.Value = "Yes" Then ' Only do the following if 'Yes' found in relevant cell column C
 
        EMailTo = Range("D" & Num).Value ' 'Email Parameter
        Nme = Range("B" & Num).Value ''Email Parameter - Name can be used in Mail Body
 
'Create array from row E to Z
        myarray = WorksheetFunction.Transpose(ThisWorkbook.Worksheets[COLOR=red]("Sheet2").[/COLOR]Range("E" & Num & ":" & "Z" & Num).Value)
 
'The array contains numbers and need to be strings to copy a Worksheet array.
'So convert to strings each element of array and add to NewArr
        counter = 1
    While counter <= UBound(myarray)
      StrVal = CStr(myarray(counter, 1))
 
      EmailSubject = EmailSubject & StrVal & " ,"  'Email Parameter
 
     ReDim Preserve NewArr(1 To counter)
     NewArr(counter) = StrVal
     counter = counter + 1
 
'Where rows E to Z did not contain numbers the array contains blank elements. Remove these and resize array to WSArr
     j = 0
     ReDim WSArr(LBound(NewArr) To UBound(NewArr))
      For i = LBound(NewArr) To UBound(NewArr)
      If NewArr(i) <> "" Then
      j = j + 1
      WSArr(j) = NewArr(i)
 
    End If
    Next i
    ReDim Preserve WSArr(LBound(NewArr) To j)
 
   Wend
 
'Copy the worksheets
    ThisWorkbook.Sheets(WSArr).Copy
End If
 
 
 
'*********************Do something with this new workbook************************************
 
 
 
'After copying/sending erase array and move to next
      Erase WSArr
      Erase myarray
      Erase NewArr
      EmailSubject = ""
      Next
 
End Sub

 

[daverunt]

Ok,

added the email bit.

Sub Mail_Content()
Dim myarray As Variant
Dim NewArr()
Dim oApp As Object, oMail As Object, WB As Workbook, FileName As String
 
ThisWorkbook.Activate
For Each C In Worksheets[COLOR=red]("Sheet2").[/COLOR]Range("C2:C100").Cells
        Num = C.Row ' gets row number from row 2 onward
        If C.Value = "Yes" Then ' Only do the following if 'Yes' found in relevant cell column C
 
        EmailTo = Range("D" & Num).Value ' 'Email Parameter
        Nme = Range("B" & Num).Value ''Email Parameter - Name can be used in Mail Body
 
'Create array from row E to Z
        myarray = WorksheetFunction.Transpose(ThisWorkbook.Worksheets[COLOR=red]("Sheet2").[/COLOR]Range("E" & Num & ":" & "Z" & Num).Value)
'The array contains numbers and need to be strings to copy a Worksheet array.
 
'So convert to strings each element of array and add to NewArr
        counter = 1
    While counter <= UBound(myarray)
      StrVal = CStr(myarray(counter, 1))
 
      If StrVal = "" Then
      EmailSubject = EmailSubject & StrVal 'Email Parameter
      Else
      EmailSubject = EmailSubject & StrVal & " ,"
      End If
 
     ReDim Preserve NewArr(1 To counter)
     NewArr(counter) = StrVal
     counter = counter + 1
 
'Where rows E to Z did not contain numbers the array contains blank elements. Remove these and resize array to WSArr
     j = 0
     ReDim WSArr(LBound(NewArr) To UBound(NewArr))
      For i = LBound(NewArr) To UBound(NewArr)
      If NewArr(i) <> "" Then
      j = j + 1
      WSArr(j) = NewArr(i)
 
    End If
    Next i
    ReDim Preserve WSArr(LBound(NewArr) To j)
 
   Wend
 
'Copy the worksheets
    ThisWorkbook.Sheets(WSArr).Copy
 
            Set WB = ActiveWorkbook
            FileName = "Temp.xlsx" [COLOR=red]'change to .xls if 2003 or less[/COLOR]
            On Error Resume Next
            Kill "C:\" & FileName
            On Error GoTo 0
            WB.SaveAs FileName:="C:\" & FileName [COLOR=red]'change to suit[/COLOR]
'Create the Outlook mail
 
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
        With oMail
             .To = EmailTo
             .Subject = EmailSubject
            .Attachments.Add WB.FullName
            .Display 'will display, but not send
            '.send   'when activated will send the e-mail without displaying.
        End With
'Delete the temporary file
    WB.ChangeFileAccess Mode:=xlReadOnly
    Kill WB.FullName
    WB.Close SaveChanges:=False
    Set oMail = Nothing
    Set oApp = Nothing
'After copying/sending erase array and move to next
      Erase WSArr
      Erase myarray
      Erase NewArr
      EmailSubject = ""
 
End If
      Next
 
End Sub

 

[daverunt]

To adapt for sending 1 mail 1 line. Some small changes to the start of the macro.

ThisWorkbook.Activate
Num = InputBox("Enter the row number for the mail you wish to send")
C = Range("C" & Num)
        If C = "Yes" Then 
 EmailTo = Range("D" & Num).Value 
        Nme = Range("B" & Num).Value 
 
 
and remove [COLOR=blue]Next[/COLOR] at the end of the mail