Emailing a worksheet

**kogersdad** · 2012-05-02, 03:59 PM

I am trying to use VBA to do the following:
1) copy a specified range (for example A4:H72)
2) open a new worksheet and paste as values the range copied from step 1
3) email the newly created spreadsheet to an email address that is located in a specified cell in the original worksheet (for example T20)

I have a working code that sends the new worksheet to a hard-coded recipient as seen below but I need the email address to change without having to change the code. Please help!
Note, I cant take credit for the code below. I borrowed it so kudos to the original owner!

Code:

Sub Mail_Range()
'HARDCODED TO MAIL TO ONE PERSON
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim I As Long
    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A4:h72").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, " & _
               "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Range of " & wb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")
    If Val(Application.Version) < 12 Then
             FileExtStr = ".xls": FileFormatNum = -4143
    Else
             FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
       .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
      On Error Resume Next
       For I = 1 To 3
           .SendMail "email address goes here", _
                 "This is the Subject line"
             If Err.Number = 0 Then Exit For
       Next I
      On Error GoTo 0
     .Close SaveChanges:=False
  End With
    
    'Delete the file you have send
'    Kill TempFilePath & TempFileName & FileExtStr
   With Application
    .ScreenUpdating = True
       .EnableEvents = True
    End With
End Sub

**Ken Puls** · 2012-05-02, 05:28 PM

Try replacing "email address goes here" (including the quotes) with:

Code:

wb.Worksheets("Sheet1").Tange("T20")

Hope that helps,

**kogersdad** · 2012-05-02, 07:37 PM

ok, i tried it (see below, just in case i typed it incorrectly) but it is still not working. It performs perfectly right up to the point of emailing but then it dies. It creates the spreadsheet, pastes as values, but then stops with no error messages..

.SendMail wb.Worksheets("Sheet1").Tange("T20"), _
"This is the Subject line"
If Err.Number = 0 Then Exit For

**Ken Puls** · 2012-05-02, 07:39 PM

Ah, sorry. Made a spelling mistake in the browser. Should be:

Code:

wb.Worksheets("Sheet1").Range("T20")

My apologies!

**kogersdad** · 2012-05-02, 10:04 PM

That worked perfectly! I was even able to take it a step further and have the Email Subject change based on another cell value! Thank you SOOO much!
My workday just got a little more automated.
Tim