#Código

    Sub Envia_Email()
        'Seleciona o intervalo de células na planilha ativa.
        Application.DisplayAlerts = False            'desabilite o alerta
    
    
        Sheets("Base filtrada").Select
    
        Dim email_envio As Variant
    
        email_envio = Range("AP2")                   'e-mail para qual será enviado
        descricao = Range("AQ2")
    
        Set rngInicial = Range("R1")
        rngInicial.Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
    
        'https://stackoverflow.com/a/48496434/7690982
        Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
        Set rng = Selection
        'Debug.Print rng.Address 'Verifica os endereços da Seleção
        HtmlContent = "<table>"
    
        For i = rngInicial.Row To rngInicial.Row + rng.Rows.Count - 1
            HtmlContent = HtmlContent & "<tr>"
            For j = rngInicial.Column To rngInicial.Column + rng.Columns.Count - 1
                HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
            Next
            HtmlContent = HtmlContent & "</tr>"
        Next
        HtmlContent = HtmlContent & "</table>"
    
        'https://stackoverflow.com/a/15161351/7690982
        Dim OApp As Object, OMail As Object
        Set OApp = CreateObject("Outlook.Application")
        Set OMail = OApp.CreateItem(0)
        With OMail
            .Display
        End With
        signature = OMail.HTMLbody
        With OMail
            Introducao = "Prezado, bom dia!." & vbCr & "Seguem os extratos atualizados nas campanhas:" 'Texto Intro Corpo do e-mail
            .To = email_envio
            .Cc = "[email protected]"               'Quem será copiado
            .Subject = "Extrato " & descricao        'Assunto do e-mail
            '.Attachments.Add
            .HTMLbody = Introducao & vbNewLine & HtmlContent & vbNewLine & signature
            .Send
        End With
        Set OMail = Nothing
        Set OApp = Nothing
    
        Application.DisplayAlerts = True             'habilite o alerta
    
    End Sub

> Obs.: Não é recomendado a utilização do `.Select` e `Selection`, há outras maneiras de realizar isso. Ver: [How to avoid using Select in Excel VBA](https://stackoverflow.com/a/10717999/7690982)

#Explicação

###Outlook

Ao invés de:

    ' Mostrar o envelope na ActiveWorkbook.
    ActiveWorkbook.EnvelopeVisible = True
    With ActiveSheet.MailEnvelope

Um objeto do Outlook com Late Binding é criado:

    'https://stackoverflow.com/a/15161351/7690982
        Dim OApp As Object, OMail As Object
        Set OApp = CreateObject("Outlook.Application")
        Set OMail = OApp.CreateItem(0)
        With OMail
            .Display
        End With

###Assinatura

Depois a Assinatura HTML padrão é usada: `signature = OMail.HTMLbody`

###Criar o e-mail e enviar

Depois o e-mail é criado e enviado:

    With OMail
        Introducao = "Prezado, bom dia!." & vbCr & "Seguem os extratos atualizados nas campanhas:" 'Texto Intro Corpo do e-mail
        .To = email_envio
        .Cc = "[email protected]"               'Quem será copiado
        .Subject = "Extrato " & descricao        'Assunto do e-mail
        '.Attachments.Add 'Para inserir Anexos
        .HTMLbody = Introducao & vbNewLine & HtmlContent & vbNewLine & signature
        .Send
    End With

###Criar tabela

A tabela com conteúdo é adicionada com o seguinte código:

    'https://stackoverflow.com/a/48496434/7690982
    Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
    Set rng = Selection
    'Debug.Print rng.Address 'Verifica os endereços da Seleção
    HtmlContent = "<table>"

    For i = rngInicial.Row To rngInicial.Row + rng.Rows.Count - 1
            HtmlContent = HtmlContent & "<tr>"
        For j = rngInicial.Column To rngInicial.Column + rng.Columns.Count - 1
            HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
        Next
        HtmlContent = HtmlContent & "</tr>"
    Next
    HtmlContent = HtmlContent & "</table>"

Em que as tags de tabulação são adicionadas para cada item do intervalo Excel que contém os dados da tabela.

##EDIT para manter a formatação:

Para manter a formatação, [a função RangetoHTML do Ron de Bruin](https://www.rondebruin.nl/win/s1/outlook/bmail2.htm) pode ser utilizada:

    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function

#Código

Então ao invés de criar a tabela, a função pode ser chamada com:

`HtmlContent = RangetoHTML(Selection)`

E o corpo HTML pode ser construído com:

`.HTMLbody = Introducao & "<br>" & HtmlContent & "<br>" & signature`