Lj, quanto a:
"As colunas G e H não estão sendo enviadas. você delimitou alguma coisa em relação as colunas?"

De fato, na instrução :
Set rng = CurrentSheet.AutoFilter.Range - Só é selecionado as Colunas que contem o Filtro, e as col. G e H não teem filtros.

Para resolver esta questão e seleciona-las tambem, devemos utilizar mais duas propriedades, Offset e Resize, então troque a rotina anterior pela a abaixo, e veja se é isto.

Sub EnviarEmailPlanilhaEspecifica()
    Dim NovoArquivoXLS As Workbook
    Dim sPlanAEnviar As String
    Dim sExcluirAnexoTemporario As String
    Dim stDestin, stTitulo As String, LR, i As Long
    Dim NewSheets As Integer
    Dim CurrentSheet As Worksheet
    
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    
    'Formato Excel 2007
    'Fonte : http://www.rondebruin.nl/saveas.htm
        'FileExtStr = ".xlsb": FileFormatNum = 50
        'FileExtStr = ".xlsx": FileFormatNum = 51
        'FileExtStr = ".xlsm": FileFormatNum = 52
        
        'Estamos utilizando este formato
        FileExtStr = ".xlsx": FileFormatNum = 51
    
    
            'Capta em opções a quantidade de Planilhas na nova pasta
            NewSheets = Application.SheetsInNewWorkbook
            
            'Defini somente uma Aba(sheet) para o novo arquivo
            Application.SheetsInNewWorkbook = 1
    
        With Sheets("Contatos")
            
            LR = .Cells(Rows.Count, 1).End(xlUp).Row
            
            For i = 1 To LR
            stDestin = .Cells(i, 1).Value
            stTitulo = .Cells(i, 2).Value
            
            'Aqui definimos qual aba
            Set CurrentSheet = Sheets("Andamento da Vaga")
            
                On Error Resume Next
                    
                'Deefine Somente o Range com os dados Filtrados
                Set rng = CurrentSheet.AutoFilter.Range
                
                ' Expandimos o range para mais duas Colunas
                Set sNewRng = rng.Offset(0, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count + 2)
            
                'copia somente os dados Filtrados
                sNewRng.Copy
            
                'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
                sPlanAEnviar = "Andamento da Vaga"
            
                'Cria um novo arquivo excel
                Set NovoArquivoXLS = Application.Workbooks.Add
            
            'cola somente os valores na planilha Ativa da nova Pasta formatada
                With ActiveSheet
                    .Range("A1").Value = "Hoje é dia :- " & Date
                    .Range("A4").PasteSpecial Paste:=xlPasteValues
                    .Range("A4").PasteSpecial Paste:=xlPasteFormats
                    .Range("A:H").Columns.AutoFit
                End With
                       
            Application.CutCopyMode = False
            
                'Define o nome da aba com o nome da aba copiada
                With ActiveSheet
                    .Name = sPlanAEnviar
                    .Range("A1").Select
                End With
   
            'Enibe a mensagem se o arquivo ja existir
            Application.DisplayAlerts = False
            
            'Salva o arquivo com o nome da aba copiada, formato 2007 - xlsx (51)
            NovoArquivoXLS.SaveAs Filename:=ThisWorkbook.Path & "" & "" & sPlanAEnviar & FileExtStr, FileFormat:=FileFormatNum
            
            sExcluirAnexoTemporario = NovoArquivoXLS.FullName
            
            'Envia o email
            NovoArquivoXLS.SendMail stDestin, stTitulo
            
            'Fecha o arquivo novo
            NovoArquivoXLS.Close
            
            'Exclui o arquivo criado apenas para ser enviado.
            Kill sExcluirAnexoTemporario
            
            Next i
        End With
        
        'Redefine a propriedade quantidade de Planilhas na nova pasta
        Application.SheetsInNewWorkbook = NewSheets

End Sub

[]s

Mauro,

Perfeito! Cara valeu de mais pela ajuda. e exatamente o que precisava, e o bom e que voce comentou todo o codigo onde ajuda também a aprender.

Mauro

O codigo esta exatamente como eu precisa so gostaria de saber uma coisa, qunado peço para enviar o sistema envia o email um a um, existe uma for de envia para todos os denstinatarios de uma vez so?

Mauro

O codigo esta exatamente como eu precisa so gostaria de saber uma coisa, qunado peço para enviar o sistema envia o email um a um, existe uma for de envia para todos os denstinatarios de uma vez so?

Lj, veja se seria isto,não me lembro cmo estava o layout, mas, em vez de fazermos o Loop em cada endereço na aba Contato, Nomeie o Range onde estão os email para "list", depois transformamos esta lista em um Array definido na Rotina e será enviado email a todos de uma vez com a propriedade "CC".

Então pára fazer os testes, que não tenho como testar aqui no serviço, substiua a rotina anterior pela a abaixo :

    Sub EnviarEmailPlanilhaEspecificaComCópia()
        Dim NovoArquivoXLS As Workbook
        Dim sPlanAEnviar As String
        Dim sExcluirAnexoTemporario As String
        Dim stDestin, stTitulo As String, LR, i As Long
        Dim NewSheets As Integer
        Dim CurrentSheet As Worksheet
        
        'Definimos a variavel para o Array
        Dim MyArr As Variant
        
        'Array com os email no range nomeado
        MyArr = Sheets("Contatos").Range("list")
       
        Dim FileExtStr As String
        Dim FileFormatNum As Long
       
        'Formato Excel 2007
        'Fonte : http://www.rondebruin.nl/saveas.htm
            'FileExtStr = ".xlsb": FileFormatNum = 50
            'FileExtStr = ".xlsx": FileFormatNum = 51
            'FileExtStr = ".xlsm": FileFormatNum = 52
           
            'Estamos utilizando este formato
            FileExtStr = ".xlsx": FileFormatNum = 51
       
                'Capta em opções a quantidade de Planilhas na nova pasta
                NewSheets = Application.SheetsInNewWorkbook
               
                'Defini somente uma Aba(sheet) para o novo arquivo
                Application.SheetsInNewWorkbook = 1
       
                'Aqui definimos qual aba
                Set CurrentSheet = Sheets("Andamento da Vaga")
               
                    On Error Resume Next
                       
                    'Deefine Somente o Range com os dados Filtrados
                    Set rng = CurrentSheet.AutoFilter.Range
                   
                    ' Expandimos o range para mais duas Colunas
                    Set sNewRng = rng.Offset(0, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count + 2)
               
                    'copia somente os dados Filtrados
                    sNewRng.Copy
               
                    'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
                    sPlanAEnviar = "Andamento da Vaga"
               
                    'Cria um novo arquivo excel
                    Set NovoArquivoXLS = Application.Workbooks.Add
               
                'cola somente os valores na planilha Ativa da nova Pasta formatada
                    With ActiveSheet
                        .Range("A1").Value = "Hoje é dia :- " & Date
                        .Range("A4").PasteSpecial Paste:=xlPasteValues
                        .Range("A4").PasteSpecial Paste:=xlPasteFormats
                        .Range("A:H").Columns.AutoFit
                    End With
                           
                    Application.CutCopyMode = False
               
                    'Define o nome da aba com o nome da aba copiada
                    With ActiveSheet
                        .Name = sPlanAEnviar
                        .Range("A1").Select
                    End With
       
                'Enibe a mensagem se o arquivo ja existir
                Application.DisplayAlerts = False
               
                'Salva o arquivo com o nome da aba copiada, formato 2007 - xlsx (51)
                NovoArquivoXLS.SaveAs Filename:=ThisWorkbook.Path & "" & "" & sPlanAEnviar & FileExtStr, FileFormat:=FileFormatNum
               
                sExcluirAnexoTemporario = NovoArquivoXLS.FullName
               
                'Envia o email aos endereços definidos no Array
                'NovoArquivoXLS.SendMail stDestin, stTitulo
                NovoArquivoXLS.SendMail Recipients:=MyArr, Subject:="Assunto Teste"
    
                'Fecha o arquivo novo
                NovoArquivoXLS.Close
               
                'Exclui o arquivo criado apenas para ser enviado.
                Kill sExcluirAnexoTemporario
               
            'Redefine a propriedade quantidade de Planilhas na nova pasta
            Application.SheetsInNewWorkbook = NewSheets

    End Sub

Lembrando, não esqueça de Nomear o Range com a lista dos emails.

[]s

Mauro,
Boa tarde!

nao entendi bem quando vc pede para o renomei para list copiei o codigo e fiz a alteração mas nao rodou.

Mauro,

Já conseguimos entender aqui e fizemos mais alguns ajustes agora ficou show.

Veja:

sendo que agora ele faz a leitura da primeira coluna de A1 até A100 o que atende muito bem .
'Array com os email no range nomeado
MyArr = Sheets("Contatos").Range("A1:A100")

Criamos aqui tambem detal forma que o email vai no campo assunto a data do dia.

Dim assunto As String

assunto = "Andamento de Vagas - " & Date

'Envia o email aos endereços definidos no Array
NovoArquivoXLS.SendMail Recipients:=MyArr, Subject:=assunto

Ficou muito bom valeu meso pela ajuda.

Lj, apesar da sua solução, o ideal seria criar um Range Nomeado Dinamico, assim só são capturados as celulas que estiverem preenchidas, não necessitando definir diretamente na rotina igual fez (A1:A100).

De uma olhada no link abaixo, tem como Nomear o range por formula e por VBA, e qualquer duvida retorne.

Create a Dynamic Named Range
http://www.contextures.com/xlnames01.html

[]s

olá Meu nome é Felipe.

utilizo essa planilha para confirmar a entrega de equipamentos reparados ao cliente.
necessito de um código para inserir em uma macro que utilizo...
gostaria que quando clicasse no botão, a planilha ativa (em PDF) fosse enviada diretamente para o email que esta na celula ex(W6).Nessa celular utilizo o PROCV para preencher automaticamente o email do cliente de acordo com o banco de dados.

ele já está funcionando a conversão para PDF e abrindo a janela de envio do email.Gostaria somente de acrescentar um código para preencher o email automaticamente.

estou utilizando o codigo abaixo:

Sub Envia_email()

' Envia_email Macro
' envia documento por email.

'Salva o arquivo
ActiveWindow.SmallScroll Down:=-15
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:DesktopCONFIRMAÇÃO DE ENTREGA.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveWindow.SmallScroll Down:=21

'Nome do Arquivo a ser anexado
Filename = "C:DesktopCONFIRMAÇÃO DE ENTREGA.pdf"

'Envia o email

Set myActiveSheet = CreateObject("Outlook.Application")
Set objMail = myActiveSheet.CreateItem(olMailItem)
Set myAttachments = objMail.Attachments

With objMail
.TO = ""
.Subject = "Confirmação de Entrega de Equipamento(s) &data &hora"
.HTMLBody = "Prezado cliente, essa é uma confirmação de entrega dos equipamentos enviados para reparo, para confirmar o recebimento dos mesmos, basta abrir o arquivo PDF em anexo e clicar no link em <u>verde</u>. Caso ainda não tenha recebido os equipamentos e queira informar nossa equipe de logistica, basta clicar no link em <u>vermelho</u>."
myAttachments.Add Filename
.display

End With

End Sub

obrigado desde já!