VBA - Email selected cells from a worksheet via email

[niecy123]

hi All,

I am stuck on this for 2 nights and I cant find a solution on the internet. Maybe it just doesn't work.

What I am trying to do

Attach two different tabs and attach them as attachment.

With the current tab - Put some few rows in the body of the email

Then save Rows 43 -95 into another excel spreadsheet and attach along with the other two attachments.

So in total we have three attachments. 2 complete tabs and 1 partial tab and then there is a body for the email.

At the moment its just attaching all 3 sheets but I on the third sheet I only want a range to be copied - not the full sheet.

Sub cOepmo()

    Dim FileExtStr As String
    Dim FileExtStr2 As String
    Dim fileExtStr3 As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim TempFileName2 As String
    Dim tempfilename3 As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Set rng = Nothing
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Sourcewb = ActiveWorkbook
    
    email1 = Range("C6")
    email2 = Range("C7")
    email3 = Range("C8")
    Title = Range("C10")
    
Set rng = Sheets("PMO").Range("C13:g35").SpecialCells(xlCellTypeVisible)
 
'*****First sheet*****************
Sheets("CoEHandoffLocations").Visible = True
    Sheets("CoEHandoffLocations").Copy
    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 worksheet to values if you want
        With Destwb.Sheets("CoEHandoffLocations").UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Destwb.Sheets(1).Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    Destwb.Close savechanges:=False
    Sheets("CoEHandoffLocations").Visible = False
    
'*****Second sheet*****************
Sheets("ConstructionStandards").Visible = True
    Sheets("ConstructionStandards").Copy
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr2 = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr2 = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr2 = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr2 = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr2 = ".xls": FileFormatNum = 56
            Case Else: FileExtStr2 = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
       'Change all cells in the worksheet to values if you want
        With Destwb.Sheets("ConstructionStandards").UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName2 = Destwb.Sheets(1).Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    Destwb.SaveAs TempFilePath & TempFileName2 & FileExtStr2, FileFormat:=FileFormatNum
    Destwb.Close savechanges:=False
    
Sheets("ConstructionStandards").Visible = False

'*****Third Sheet*****************
    Sheets("PMO").Copy
    Set Destwb = ActiveWorkbook
    
    
'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            fileExtStr3 = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: fileExtStr3 = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    fileExtStr3 = ".xlsm": FileFormatNum = 52
                Else
                    fileExtStr3 = ".xlsx": FileFormatNum = 51
                End If
            Case 56: fileExtStr3 = ".xls": FileFormatNum = 56
            Case Else: fileExtStr3 = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
       'Change all cells in the worksheet to values if you want
        With Destwb.Sheets("PMO").UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
        
       
        Application.CutCopyMode = False
        
        
  
     
    On Error Resume Next
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    tempfilename3 = Destwb.Sheets(1).Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    
    Destwb.SaveAs TempFilePath & tempfilename3 & fileExtStr3, FileFormat:=FileFormatNum
    Destwb.Close savechanges:=False
    

    '******Create the mail******
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = email1
            .CC = email2
            .BCC = email3
            .Subject = Title
            .htmlBody = RangetoHTMLzz(rng)
            .Attachments.Add TempFilePath & TempFileName & FileExtStr
            .Attachments.Add TempFilePath & TempFileName2 & FileExtStr2
            .Attachments.Add TempFilePath & tempfilename3 & fileExtStr3
            .Display
         
        End With
        On Error GoTo 0
    '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