Email selected sheets (Excel 2003 SP3)

[steveh]

Morning all

I have a workbook and 61 of the worksheets represent Employee's, on every worksheet cell C8 shows the department to which that Employee is a part off, C8 on some some of the worksheets will be blank and will not need to be emailed.

What I am trying to do is to be able to select a department via a data validated cell and then click a button which will identify the department from the selection and then only email those sheets where the department matches in C8.

I have some excellent mail examples from Ron de Bruin and the MSKB (which I think are Ron's anyway) but I cannot seem to adapt them to my use.

Can anybody suggest a change to the code below which would look at a cell, let us say B31 (although that may change later) on a work sheet named Reports and then match the value with cell C8 in worksheets emp1:emp61 and then temporarily combine those sheets for emailing.

Code: Select all

Sub EmailWithOutlooka()
     
    Dim oApp As Object, _
    oMail As Object, _
    WB As Workbook, _
    FileName As String
     
    Application.ScreenUpdating = False
     
    ActiveSheet.Copy
    Set WB = ActiveWorkbook
    FileName = "Departmental Yearly Summary.xls"
    On Error Resume Next
    Kill "C:\" & FileName
    On Error GoTo 0
    WB.SaveAs FileName:="C:\" & FileName
     
         Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
         .Subject = "Departmental Annual Summary!"
        .Attachments.Add WB.FullName
        .Display
    End With
     
         WB.ChangeFileAccess Mode:=xlReadOnly
    Kill WB.FullName
    WB.Close SaveChanges:=False
     
       Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
End Sub

[HansV]

Try this:

Code: Select all

Sub EmailWithOutlooka()
    Dim oApp As Object
    Dim oMail As Object
    Dim wbkSource As Workbook
    Dim wbkTarget As Workbook
    Dim wsh As Worksheet
    Dim strDepartment As String
    Const strFileName = "C:\Departmental Yearly Summary.xls"

    Application.ScreenUpdating = False

    Set wbkSource = ActiveWorkbook
    strDepartment = wbkSource.Worksheets("Reports").Range("B31")
    ' Create target workbook with one sheet
    Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
    ' Loop through sheets of source workbook
    For Each wsh In wbkSource.Worksheets
        ' Check cell C8
        If wsh.Range("C8") = strDepartment Then
            ' Copy sheet to target workbook
            wsh.Copy After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count)
        End If
    Next wsh
    ' Did we add any sheets?
    If wbkTarget.Worksheets.Count = 1 Then
        ' If not, get out
        MsgBox "No sheets for this department!", vbInformation
        wbkTarget.Close SaveChanges:=False
        Exit Sub
    End If
    ' Remove blank first sheet
    wbkTarget.Worksheets(1).Delete
    
    On Error Resume Next
    Kill strFileName
    On Error GoTo ErrHandler
    wbkTarget.SaveAs FileName:=strFileName
    wbkTarget.Close

    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then
        Set oApp = CreateObject("Outlook.Application")
        If oApp Is Nothing Then
            MsgBox "Can't start Outlook!", vbExclamation
            GoTo ExitHandler
        End If
    End If
    On Error GoTo ErrHandler
    Set oMail = oApp.CreateItem(0)
    With oMail
        .Subject = "Departmental Annual Summary!"
        .Attachments.Add strFileName
        .Display
    End With

ExitHandler:
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
    On Error Resume Next
    Kill strFileName
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[steveh]

Try this:

Hi Hans

Thank you very much for the example. I am facing a couple of challenges which I have tried to address but can't quite seem to get there

First of all I am getting this message box when I am running the code

DataExists.gif

Which goes when I click cancel and does not seem to delete anything but can I supress it.

The code also still generates a blank sheet1 which I can live with if necessary but I also have another couple of sheets that may contain the value in cell C8 which do not need to be sent so I tried

Code: Select all

For Each wsh In Worksheets
        
Select Case wsh.Name
    Select Case wsh.Name
            Case "Summary", "CheckLeave", 

Case Else

But this errors on Select Case wsh.Name with a compile error?

[HansV]

Try this version

Code: Select all

Sub EmailWithOutlooka()
    Dim oApp As Object
    Dim oMail As Object
    Dim wbkSource As Workbook
    Dim wbkTarget As Workbook
    Dim wsh As Worksheet
    Dim strDepartment As String
    Const strFileName = "C:\Departmental Yearly Summary.xls"

    Application.ScreenUpdating = False

    Set wbkSource = ActiveWorkbook
    strDepartment = wbkSource.Worksheets("Reports").Range("B31")
    ' Create target workbook with one sheet
    Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
    ' Loop through sheets of source workbook
    For Each wsh In wbkSource.Worksheets
        Select Case wsh.Name
            Case "Summary", "CheckLeave"
                ' Don't copy
            Case Else
                ' Check cell C8
                If wsh.Range("C8") = strDepartment Then
                    ' Copy sheet to target workbook
                    wsh.Copy After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count)
                End If
        End Select
    Next wsh
    ' Did we add any sheets?
    If wbkTarget.Worksheets.Count = 1 Then
        ' If not, get out
        MsgBox "No sheets for this department!", vbInformation
        wbkTarget.Close SaveChanges:=False
        Exit Sub
    End If
    ' Remove blank first sheet
    Application.DisplayAlerts = False
    wbkTarget.Worksheets(1).Delete
    Application.DisplayAlerts = True
    
    On Error Resume Next
    Kill strFileName
    On Error GoTo ErrHandler
    wbkTarget.SaveAs Filename:=strFileName
    wbkTarget.Close

    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then
        Set oApp = CreateObject("Outlook.Application")
        If oApp Is Nothing Then
            MsgBox "Can't start Outlook!", vbExclamation
            GoTo ExitHandler
        End If
    End If
    On Error GoTo ErrHandler
    Set oMail = oApp.CreateItem(0)
    With oMail
        .Subject = "Departmental Annual Summary!"
        .Attachments.Add strFileName
        .Display
    End With

ExitHandler:
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
    On Error Resume Next
    Kill strFileName
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[steveh]

Try this version

That is fantastic Hans, thank you very much