Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
macro: filtrar+copi...
 
Notifications
Clear all

macro: filtrar+copiar+enviar por email+deletar o arq. temp.

 
Página 1 / 2
2024 - VBA & Macros
16 Posts
2 Usuários
0 Reactions
2,914 Visualizações
RSS
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

quero, mas não consigo, eheheh. é difícil essas coisas de macro.
antes que alguém fale, olha, tentei pesquisar, não achei nada semelhante, eu também tentei copiar um pouco de cada código e não consigo fazer conforme abaixo, por isso, que venho aqui pedir ajuda.

tenho excel 2003 e outlook 2003.

Tenho uma planilha chamada pedidos_teste, o arquivo do excel está no link:

https://skydrive.live.com/redir?resid=2 ... mpx1Zki0ig

quero criar uma macro que pudesse:

filtrar a coluna conferido, apenas o sim, copiar todos os dados para uma nova planilha temporária, sem as colunas: n, o, p e q.

e enviar para um e-mail fixo, com o título do assunto: atualização do "pegar o texto sempre da coluna A, linha 1" e no corpo do texto:

Boa tarde, favor atualizar o site com a planilha em anexo.

Obrigado.

é isso.

pra mim é muito complicado, mas acho que alguém já fez algo semelhante, eu não achei na pesquisa, se puderem indicar ou ajudar, será muito bom pra nós do serviço.

SE pudesse ajudar, será ótimo, sem palavras pra agradecer, pois preciso muito no serviço.

Obrigado.

Carmelito.

 
Postado : 27/01/2013 10:25 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

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

 
Postado : 27/01/2013 12:14 pm
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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.

 
Postado : 27/01/2013 12:52 pm
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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

 
Postado : 27/01/2013 5:48 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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
 
Postado : 27/01/2013 6:58 pm
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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
 
Postado : 28/01/2013 6:27 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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

 
Postado : 28/01/2013 6:32 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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

 
Postado : 28/01/2013 6:49 am
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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
 
Postado : 28/01/2013 10:10 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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

 
Postado : 28/01/2013 10:27 am
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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!!!!

 
Postado : 28/01/2013 10:40 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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
 
Postado : 28/01/2013 11:00 am
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

.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.

 
Postado : 28/01/2013 11:29 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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
 
Postado : 28/01/2013 11:31 am
 carmelito
(@carmelito)
Posts: 24
Eminent Member
Topic starter
 

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.

 
Postado : 28/01/2013 12:13 pm
Página 1 / 2
Forum Jump:
  Tópico Anterior
Próximo Tópico