Boa tarde!!

Fiz uma parte, para enviar por email veja: http://www.rondebruin.nl/sendmail.htm
http://www.sendspace.com/file/v8oy1u
Att

MUito obrigado pela ajuda, ainda mais no domingo. Hoje em dia não tem mais finais de semana e semana, trabalhamos quase todos os dias, inclusive nos finais de semana, acho que é pra maioria, hoje em dia.
Amigão, diz uma coisa, tem como copiar tudo até a linha 6, menos o botão, e depois copiar a pesquisa, como você fez?!
E outra coisa, essa copia, em vez de fazer em outra planilha, como eu faço pra copiar no c:arquivo_teste_para_email.xls
Muito obrigado mesmo pela ajuda. Está ficando muito tri.

Obrigado pela ajuda, dividi o problema em partes, agora estou na parte que não consigo enviar com a formatação original, com filtros, cor, mas sem fórmulas, apenas os dados, o que está acontecendo quando clico no botão, ele envia a tabela, porém nas colunas datas está como número, ou seja, está perdendo toda a formatação. SErá que podes ajudar? Obrigado.
https://skydrive.live.com/redir?resid=2 ... lKKKVA1alo

Boa noite!!

Eu não baixei seu ultimo modelo.
faça os teste e tente adaptar.

Sub testeAleVBA()
    Dim wbMe As Workbook, wbOpen As Workbook
    Dim strSheet  As String
     
    strSheet = ActiveSheet.Name
    Set wbMe = ThisWorkbook
     
    ChDir "C:"
    Set wbOpen = Workbooks.Open _
    (Filename:="C:arquivo_teste_para_email.xls", Editable:=True)
    wbMe.Sheets(strSheet).Range("A1:M1000").copy _
    Destination:=wbOpen.Sheets("Plan1").Range("A1")
    Call Delet_AleVBA
End Sub
Sub Delet_AleVBA()
    Dim lRows As Long
    Application.Workbooks("aleVBA.xlsx").Worksheets("Plan1").Select
    With Range("A7:M7")
     .AutoFilter
     .AutoFilter Field:=5, Criteria1:="sim"
    End With
    Application.Calculation = xlCalculationManual
    For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
    Next lRows
    ActiveSheet.AutoFilterMode = False
    Application.Calculation = xlCalculationAutomatic
End Sub

Obrigadão, mas aquele código está aparecendo erro pra depurar a linha: Application.Workbooks("aleVBA.xlsx").Worksheets("Plan1").Select

mas, será que não dá pra me ajudar naquele código, pois agora está quase tudo pronto, olha como ficou o seu código e mais o que eu achei na internet pra enviar o email, só queria que tivesse a formatação da planilha original.

código do botão.

Sub Copiar_AleVBA()
Application.ScreenUpdating = False
   Sheets("plan1").Cells.ClearContents
   ThisWorkbook.Sheets("edital").Range("a1:m1000").Copy
  Sheets("Plan1").Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues
   Application.CutCopyMode = False
   Call Delet_AleVBA
   Application.ScreenUpdating = True
End Sub

Sub Delet_AleVBA()
    Dim lRows As Long
    Sheets("Plan1").Select
    With Range("A7:M7")
     .AutoFilter
     .AutoFilter Field:=5, Criteria1:="sim"
    End With
    Application.Calculation = xlCalculationManual
    For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
    Next lRows
    ActiveSheet.AutoFilterMode = False
    Application.Calculation = xlCalculationAutomatic
    
    Call EnviarEmailPlanilhaEspecifica
End Sub

Sub EnviarEmailPlanilhaEspecifica()
2   Dim NovoArquivoXLS As Workbook
3   Dim sPlanAEnviar As String
4   Dim sExcluirAnexoTemporario As String
5
6   'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
7    sPlanAEnviar = "Plan1"
8
9    'Cria um novo arquivo excel
10   Set NovoArquivoXLS = Application.Workbooks.Add
11
12   'Copia a planilha para o novo arquivo criado
13   ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)
14
15   'Salva o arquivo
16   NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xls"
17  sExcluirAnexoTemporario = NovoArquivoXLS.FullName
18
19   'Envia o email
20   NovoArquivoXLS.SendMail "xxxx@gmail.com", "Título do Email teste"
21
22   'Fecha o arquivo novo
23   NovoArquivoXLS.Close
24
25  'Exclui o arquivo criado apenas para ser enviado.
26  Kill sExcluirAnexoTemporario
27  Sheets("Plan1").Cells.ClearContents
28  End Sub

Bom dia!!

Deu erro porque o código está procurando ao que não está ai! (aleVBA.xlsx) esse é o arquivo que eu fiz como teste.

Altere o nome para um arquivo existente no seu diretório.

Em quanto isso vou ver se consigo certar o outro.

Att

Bom dia!!

Substitua o código abaixo

Sub Copiar_AleVBA()
Application.ScreenUpdating = False
   Sheets("plan1").Cells.ClearContents
   ThisWorkbook.Sheets("edital").Range("a1:m1000").Copy
  Sheets("Plan1").Range("A" & Rows.Count).End(xlUp).PasteSpecial 12 <-- Linha alterarda
   Application.CutCopyMode = False
   Call Delet_AleVBA
   Application.ScreenUpdating = True
End Sub

Att

eu mudei o pastespecial para 12, porém não vem as bordas e nem as cores das células, então mudei para xlPasteAll
aí vem tudo, porém vem as fórmulas junto, queria os valores mas sem as fórmulas.
tem alguma ideia! Está quase no fim, graças a ajuda de vc, olha tu sabe tudo disso que bom.

código atual do botão.

Sub Copiar_AleVBA()
Application.ScreenUpdating = False
   Sheets("plan1").Cells.ClearContents
   ThisWorkbook.Sheets("edital").Range("a1:m1000").Copy
  Sheets("Plan1").Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteAll
   Application.CutCopyMode = False
   Call Delet_AleVBA
   Application.ScreenUpdating = True
End Sub
Sub Delet_AleVBA()
    Dim lRows As Long
    Sheets("Plan1").Select
    With Range("A7:M7")
     .AutoFilter
     .AutoFilter Field:=5, Criteria1:="sim"
    End With
    Application.Calculation = xlCalculationManual
    For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
    Next lRows
    ActiveSheet.AutoFilterMode = False
    Application.Calculation = xlCalculationAutomatic
    
    Call EnviarEmailPlanilhaEspecifica
End Sub

Sub EnviarEmailPlanilhaEspecifica()
2   Dim NovoArquivoXLS As Workbook
3   Dim sPlanAEnviar As String
4   Dim sExcluirAnexoTemporario As String
5
6   'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
7    sPlanAEnviar = "Plan1"
8
9    'Cria um novo arquivo excel
10   Set NovoArquivoXLS = Application.Workbooks.Add
11
12   'Copia a planilha para o novo arquivo criado
13   ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)
14
15   'Salva o arquivo
16   NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xls"
17  sExcluirAnexoTemporario = NovoArquivoXLS.FullName
18
19   'Envia o email
20   NovoArquivoXLS.SendMail "xxxx@xxx.x", "Título do Email teste"
21
22   'Fecha o arquivo novo
23   NovoArquivoXLS.Close
24
25  'Exclui o arquivo criado apenas para ser enviado.
26  Kill sExcluirAnexoTemporario
27  Sheets("Plan1").cell.ClearContents
28  End Sub

Boa tarde!!

Desculpa cara, mas só agora que me dei conta, você deve usar uma versão (inferior), diferente da minha, eu uso 2007, foi por isso que não deu certo com você, pois eu havia testado e comigo deu certo, como eu não tenho o excel2003 (acho que você usa ele), vou ver se consigo resolver.

Att

que complicação: eu mudei o seu PasteSpecial 12 para xlPasteAll
aí copiava tudo mesmo, porém as fórmulas das células também copia, mas não queria, então utilizei o
xlPasteValuesAndNumberFormats

os dados ficam perfeitos, porém não copia as bordas, e as cores das celulas, que complicação!!!! mas é um pequeno detalhe, e que detalhe!!!!

Boa tarde!!

Cara veja se vai dar certo NÃO TESTADO!! (eu não tenho o excel 2003)

Option Explicit

Sub copy_paste_with_shapes_values_and_edges()
Application.ScreenUpdating = False
   Sheets("Plan1").Cells.ClearContents
   ThisWorkbook.Sheets("edital").Range("a7:m1000").copy
   With Sheets("Plan1").Range("A" & Rows.Count).End(xlUp) '<-- ALTERAÇÃO
     .PasteSpecial xlPasteFormats
     .PasteSpecial xlPasteValues
   End With                                                                          '<-- ALTERAÇÃO
   Application.CutCopyMode = False
   Call Delet_AleVBA
   Application.ScreenUpdating = True
End Sub

.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
perfeito amigo, valeu pelo grande trabalho, que é seu, apavorou, agora vou descobrir na internet como alinhar as linhas e colunas automaticamente, pois muitas estão escondendo o texto que tem, mas se não tiver na mão, pode deixar, eu vi em algum lugar da internet, muito obrigado.

Boa tarde!!
Tente adptar...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Ajustar linha e coluna automaticamente
    For Each Cell In Target
        If Len(Cell.Value) > 5 Then
            Columns(Cell.Column).EntireColumn.AutoFit
            Rows(Cell.Row).EntireRow.AutoFit
           
        End If
    Next Cell
End Sub

Ficou 90% melhor ao colocar os códigos abaixo.

Selection.Columns.AutoFit
Selection.Rows.AutoFit

valeu amigão.
agora vou ver outra parte, de enviar email, mas no corpo do email colocar algumas células da plan1, valeu.