VBA: Extracting Sheets as Attachments, Attachment Defined by Varying Range

[sarah3300]

Found this code online, but making adjustments. I have a worksheet in my workbook (say Sheet5) that has a list of user defined sheet names (say the range is defined from C2:C20 in sheet5). I need to send an email with the sheets defined from the user that are listed in C2:C20 as attachments.

So essentially tell Excel, "only email the sheets that are defined in range C2:C20 in Sheet5" - the values can vary depending on the user (so sometimes the user might put in 2 named worksheets, sometimes they might put in 5). The sheets that are defined by the user will always be found in the current workbook. Additionally I have one sheet that will always be named "Sheet6", and will always need to be sent with the other attachments.

I'm having trouble coding this, below I bolded the portion that I'm making adjustments to. But I can't get the code to work the way I want to. Sometimes I'll get an out of range errors, other times it'll create a workbook with Sheet 6, and the last user defined sheet name (so if the user inputted 3 sheet names in C2:C20, it only pulls the last sheet name inputted).


Sub Email()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim rcell As Range
Dim rRange As Range


With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook

'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped

With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow

Set rRange = Sheets("Sheet5").Range("C2:C20")

For Each rcell In rRange
If rcell.Value <> "" Then
.Sheets(Array(rcell.Value, "Sheet6")).Copy
End If
Debug.Print rcell.Value
Next

End With

'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format

With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With

' 'Change all cells in the worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "test@gmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName

'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub