Export sheet in new workbook based on cell value from down list

[wombatmonkey]

Hi all

I have a drop down list in cell A1 with different values. For example, one of the values is equal to "sheet1". There are also other sheets within the workbook that equals the different values in A1 list. Ideally, I like to pick one of the values (e.g. "sheet1") in A1 and then click on a button with an assigned macro. The macro will find the sheet name equal to A1 (e.g. "sheet1"), create a copy of the sheet into a new workbook, values only/no formulas, and then attach the new workbook, values only, to an email. Thank you in advance!

 

[ranman256]

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library
paste code below into a module.
then run: copySheet2email

Option Explicit
Sub copySheet2email()
'copy sheet data VALUES to new sheet, then email
Dim rng As Range
Dim sWS As String
Dim vFile, vDir
sWS = Range("A1").Value
vDir = "c:\temp\"
vFile = vDir & sWS & "_" & Format(Now, "yymmdd-hhnn") & ".xls"

Sheets(sWS).Activate
Range("A1").Select
    Set rng = ActiveSheet.UsedRange
    rng.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select
    ActiveWorkbook.SaveAs vFile
    ActiveWorkbook.Close
  
       'send email
    Send1Email "WECoyote@acme.com", "your xl sheet", "here is " & sWS, vFile
End Sub

Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
  
    .Display True   'show user but dont send yet
    '.Send          'send now
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function

 

[mumps]

Try:

Sub SavePDF_Email()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String
    val = Range("A1").Value
    Sheets(Range("A1").Value).Copy
    ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
    ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = ""
        .Subject = ""
        .HTMLBody = ""
        .attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    Application.ScreenUpdating = True
End Sub

Change the save path (in red) to suit your needs.

 

[wombatmonkey]

Try:

Sub SavePDF_Email()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String
    val = Range("A1").Value
    Sheets(Range("A1").Value).Copy
    ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
    ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = ""
        .Subject = ""
        .HTMLBody = ""
        .attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    Application.ScreenUpdating = True
End Sub

Change the save path (in red) to suit your needs.

Thank you very much! Have a few more questions:

1) For the To, CC, subject, body fields, how do I reference a cell value instead of a static value in quotes " "?
2) After the sheet is copied/saved/attached to the email, is there a way to close the new workbook automatically?
3) If there is no matching sheet name that equals cell A1, is there a way to continue to open draft the email even though there's no need to include an attachment?

 

[mumps]

Try:

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String
    val = Range("A1").Value
    If Evaluate("isref('" & val & "'!A1)") Then
        Sheets(Range("A1").Value).Copy
        ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
        ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Range("B1").Value
            .Subject = Range("B2").Value
            .HTMLBody = Range("B3").Value
            .attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        ActiveWorkbook.Close False
    Else
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Range("B1").Value
            .Subject = Range("B2").Value
            .HTMLBody = Range("B3").Value
            .Display
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Change the ranges (in red) to suit your needs.

 

[wombatmonkey]

Try:

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String
    val = Range("A1").Value
    If Evaluate("isref('" & val & "'!A1)") Then
        Sheets(Range("A1").Value).Copy
        ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
        ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Range("B1").Value
            .Subject = Range("B2").Value
            .HTMLBody = Range("B3").Value
            .attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        ActiveWorkbook.Close False
    Else
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Range("B1").Value
            .Subject = Range("B2").Value
            .HTMLBody = Range("B3").Value
            .Display
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Change the ranges (in red) to suit your needs.

When I run the macro, the new updates work. However, when referencing the cells (B1, B2, B3) for the To/Subject/Body values, it references those cells from the sheet that's being copied and attached. How do I reference cells (B1 B2 B3) from the same sheet that has the A1 drop down list?

 

[mumps]

Change the sheet name (in red) that has the A1 drop down list to suit your needs.

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String, WB As Workbook
    Set WB = ThisWorkbook
    val = Range("A1").Value
    If Evaluate("isref('" & val & "'!A1)") Then
        Sheets(Range("A1").Value).Copy
        ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
        ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = WB.Sheets("Sheet1").Range("B1").Value
            .Subject = WB.Sheets("Sheet1").Range("B2").Value
            .HTMLBody = WB.Sheets("Sheet1").Range("B3").Value
            .attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        ActiveWorkbook.Close False
    Else
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = WB.Sheets("Sheet1").Range("B1").Value
            .Subject = WB.Sheets("Sheet1").Range("B2").Value
            .HTMLBody = WB.Sheets("Sheet1").Range("B3").Value
            .Display
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[wombatmonkey]

Change the sheet name (in red) that has the A1 drop down list to suit your needs.

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, val As String, WB As Workbook
    Set WB = ThisWorkbook
    val = Range("A1").Value
    If Evaluate("isref('" & val & "'!A1)") Then
        Sheets(Range("A1").Value).Copy
        ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
        ActiveWorkbook.SaveAs Filename:="C:\Test\" & val & ".xlsx"
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = WB.Sheets("Sheet1").Range("B1").Value
            .Subject = WB.Sheets("Sheet1").Range("B2").Value
            .HTMLBody = WB.Sheets("Sheet1").Range("B3").Value
            .attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        ActiveWorkbook.Close False
    Else
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = WB.Sheets("Sheet1").Range("B1").Value
            .Subject = WB.Sheets("Sheet1").Range("B2").Value
            .HTMLBody = WB.Sheets("Sheet1").Range("B3").Value
            .Display
        End With
    End If
    Application.ScreenUpdating = True
End Sub

You are amazing! Thank you very much.

 

[mumps]

You are very welcome.