Veja se seria 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 CurrentSheet As Worksheet
    
        With Sheets("Plan5")
            
            LR = .Cells(Rows.Count, 1).End(xlUp).Row
            
            For i = 1 To LR
            stDestin = .Cells(i, 1).Value
            stTitulo = .Cells(i, 2).Value
            
            Set CurrentSheet = ActiveSheet
            
                    On Error Resume Next
                       
                    'copia todas as células da planilha ativa
                    CurrentSheet.Cells.Copy
            
            'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
            sPlanAEnviar = "calculo"
            
            '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")
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .PasteSpecial Paste:=xlFormats
                End With
                       
            Application.CutCopyMode = False
            
            'Salva o arquivo
            NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xls"
            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

End Sub

[]s

Mauro Coutinho
Acho que você atendeu meu pedido porém antes a botão da macro estava em uma planilha e buscava a aba superteste e agora esta buscando a tela onde a macro aba onde o botão enviar email esta.

possa ser que tenha feito alguma alteração dentro desta parte.

'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
sPlanAEnviar = "superteste"

ou algum parâmetro colocado antes.

mas fico grato desde já

lj, a rotina faz uma cópia da aba em que está o foco.

Se entendi, você quer enviar mais de uma - "Plan1, Balancete, Lista De Nomes, etc".

Se for isto, estes nomes são das abas em um ou de arquivos separados ?

[]s

Mauro,

vou posta exatamente com esta meu código hoje. o que preciso e exatamente o que você fez manda a planilha ( no meu caso que seja enviada aba Andamento da vaga)

O botão de enviar email fica na aba resumo. porem o código que você me mandou quando clico ele envia a aba onde esta o botão e não a aba andamento da vaga.

Resumindo o que preciso e que este código envie email com apenas uma a aba andamento da vaga e não vá com formulas somente os dados em forma de texto ( com se estivesse copiado e colado especial / valores).

segue meu código novamente se puder ajustar esta opção fico grato.

Sub EnviarEmailPlanilhaEspecifica()
Dim NovoArquivoXLS As Workbook
Dim sPlanAEnviar As String
Dim sExcluirAnexoTemporario As String
Dim stDestin, stTitulo As String, LR, i As Long

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

'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

'Copia a planilha para o novo arquivo criado
ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)

'Salva o arquivo
NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xls"
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

End Sub

Mauricio.

pelo que entendi você tirou esta parte.

'Copia a planilha para o novo arquivo criado
ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)

e parece que ela que esta dificultando o envio da aba correta.

lj, é Mauro e não Mauricio, rsrsrsrsr

Veja se agora acertamos:

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
    
        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
            
            'Set CurrentSheet = ActiveSheet - Aqui pegava a aba ativa
            
            'Aqui definimos qual aba
            Set CurrentSheet = Sheets("Andamento da Vaga")
            
                    On Error Resume Next
                       
                    'copia todas as células da planilha ativa
                    CurrentSheet.Cells.Copy
            
            'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
            sPlanAEnviar = "Andamento da Vaga"
            
            '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

            '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")
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .PasteSpecial Paste:=xlFormats
                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
            NovoArquivoXLS.SaveAs Filename:=ThisWorkbook.Path & "" & "" & sPlanAEnviar & ".xls"

            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

Pode ser executada a partir de qualquer aba, desde que exista uma aba chamada "Andamento da Vaga".

faça os testes e qq duvida, retorne.

[]s

Amigo Mauro,

Primeiramente gostaria de pedir desculpa pelo erro de seu nome (rs).

bom agora voltou a enviar a planilha Andamento de Vaga porém foi em branco. sem nenhuma informação que continha na aba.

Lj, no modelo que montei para testar, funcionou corretamente, talvez seja layout diferente em seu arquivo, se não conseguir e se puder anexar um modelo reduzido de como está o seu arquivo, fica mais facil.

Agor estou saindo para almoçar, mais tardee vejo.

[]s

segue

Lj, troque a rotina pela a abaixo :

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
    
            '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
            
            'Set CurrentSheet = ActiveSheet - Aqui pegava a aba ativa
            
            'Aqui definimos qual aba
            Set CurrentSheet = Sheets("Andamento da Vaga")
            
                    On Error Resume Next
                       
                    'copia todas as células da planilha ativa
                    CurrentSheet.Cells.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")
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .PasteSpecial Paste:=xlFormats
                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
            NovoArquivoXLS.SaveAs Filename:=ThisWorkbook.Path & "" & "" & sPlanAEnviar & ".xls"

            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

O problema estava na instrução que define que o novo arquivo terá somente uma ABA, troquei de lugar e está ok.

Uma obs sobre o seu modelo, estamos copiando dados Filtrados, e na rotina copia todas as celulas que encontrar dados, ou seja, mesmo que o resultado das formulas sejam erros ou em branco eles são copiados, na sequencia acertarei para copiar somente o necessário, e tambem na instrução para Salvar, está salvando como ".xls", ou seja, v2003, só que não abre no 2003, então se não utiliza a v2003 irei acertar esta parte tambem.
Sem os acertos acima, é gerado um novo arquivo com um tamanho exorbitante, com certeza ajeitando teremos um arquivo menor.

Por enquanto, faça os testes com a rotina acima, depois posto outro exemplo com arotina modificada com as questões que citei.

[]s

Mauro,

bom fiz um teste aqui mas o arquivo demorou de mais para ser gerado e quando foi enviar esta em 16MB mas acredito que com os ajustes que você esta fazendo este erro não mais aparecerão e ficará perfeito.

fico no aguarde.

Mais uma vez muito obrigado pela ajuda.

Lj, segue um modelo com as alterações que citei acima, como a aba "resumo" está com senha, troquei a rotina diretamente no projeto VBA.

Agora é copiado somente os Dados Filtrados e colocados no novo arquivo, veja a diferença de tamanhos com o uso das duas rotinas :

Deve ter percebido que alterei para salvar na v2007 (.xlsx), esta alteração na rotina, utilizei a instrução do site abaixo :
Use VBA SaveAs in Excel 2007-2010Use VBA SaveAs in Excel 2007-2010
http://www.rondebruin.nl/saveas.htm
Se não quiser nesta versão, é só seguir as dicas do site e alterar.

Faça os testes e qualquer duvida, retorne.

Eu havia alterado o endereço do email, corrija antes de testar.
[]s

Mauro,

Já estou testando aqui mas e exatamente o que preciso.

Já já retorno a informação.

Mauro,

Já estou testando aqui mas e exatamente o que preciso.

Já já retorno a informação.

As colunas G e H não estão sendo enviadas. você delimitou alguma coisa em relação as colunas?

Mas de qualquer forma ficou foi exatamente o que preciso.