Mudar ativação de código vba

[Felipe2791]

Bom dia,

 

Tenho o código VBA abaixo, uso ele a um tempo. 

Como podem ver ele envia uma mensagem com conteudo de uma respectiva linha no Excel, a ativação é marcando um "x".

Estou tentando mudar a ativação do codigo, preciso que o email seja enviado com um botão, para que fiquei em massa.

Ou seja, tenho 100 linhas, se as 100 estiverem marcada com o "x" ao ativar o botão os emails sejam disparados juntos. Não precisa ser exatamene com x marcado, pode ser outro mecanismo, com tanto que a ação seja 1 só para todas as linhas.

 

Desde já obrigado!

 

EDIT: ADICIONEI A PLANILHA TESTE

 

 

 

Citação

Sub Worksheet_Change(ByVal Target As Range)

'Envia e-mail pelo Outlook

    Dim OutApp As Object
    Dim OutMail As Object
    Dim texto As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    linha = ActiveCell.Row - 1
    If Target.Address = "$A$" & linha Then
    If Plan1.Cells(linha, 1) = "x" Then

        With OutMail
            .To = Plan1.Cells(linha, 4)
            .CC = ""
            .BCC = ""
            .Subject = "Nível"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 3) & "," & vbCrLf & vbCrLf & _
                    "Segue acompanhamento do mês de Julho."
                    
                    
            .Display    'Send para enviar o email sem abrir o Outlook
        End With
        On Error GoTo 0
        End If

        Set OutMail = Nothing
        Set OutApp = Nothing
        
    End If
    End Sub
 

 

 

teste.rar

[darkstrikerd]

@Felipe2791 A ativação do script está ocorrendo quando há uma mudança na planilha(Worksheet_change):

Sub Worksheet_Change(ByVal Target As Range)

Você tem que trocar para um evento de clique de botão.

 

No código atual, ele envia um email checando mudanças e enviando o email com os dados somente daquela linha modificada:

 

linha = ActiveCell.Row - 1
If Target.Address = "$A$" & linha Then
If Plan1.Cells(linha, 1) = "x" Then

Você teria que fazer também um FOR, para checar todas as linhas e rodar a parte do script que envia o email para cada uma delas.

 

Estou sem o Office aqui, mas acho que com os links ai dá pra resolver.

 

 

 

 

[CasaDoHardware]

Crie um loop para verificar se a celula esta preenchida e pronto

 

Troque o nome da macro para sub enviar.

 

Depois crie uma outra macro assim

 

Sub EnvioMassa()

 

Suponha que você coloque o X na Coluna B e os emails na Coluna A (Nao vi seu arquivo)

 

Range ("A2).select

 

Do While Activecell <> "" 

 

if activecell.offset(0,1).value = "X" then

 

Enviar

 

Else

 

activecell.offset(1,0).select

 

 

end if

 

 

Loop

 

End Sub

 

Em resumo essa segunda macro vai verificar se na coluna B posssui um X se sim vai executar a macro enviar se nao pula uma linha para que possa verificar a proxima.

 

[Felipe2791]

Bom dia,

 

Obrigado aos 2 que responderam.  @CasaDoHardware - @darkstrikerd

Tentei das dua manieiras e sem sucesso, acho que estou errando em algum detalhe, tenho algumas planilhas com alguns VBAs, mas o maximo que faço é modifica-los em detalhes da maneira que preciso.

 

Podem clarear ainda mais para mim?

 

EDIT: no caso da segunda resposta o Range ("A2).select não funciona no código.

[CasaDoHardware]

Cometi um pequeno erro

 

Deveria ser assim

 

Range("A2").select 

 

Mas ja ajustei a macro a sua planilha é so copiar os codigos do modulo 1 e colar em um modulo de sua planilha original.

teste.xlsm

[Felipe2791]

9 minutos atrás, CasaDoHardware disse:

Cometi um pequeno erro

 

Deveria ser assim

 

Range("A2").select 

 

Mas ja ajustei a macro a sua planilha é so copiar os codigos do modulo 1 e colar em um modulo de sua planilha original.

teste.xlsm

@CasaDoHardware

Esta retornando um erro no If Target.Address = "$A$" & linha Then do primeiro Script.

Tentei trocar algumas coisas, mas se colocarmos o X maiusculo o erro retorna, se coloco o minusculo faz a varredura mas não gera o email.

[CasaDoHardware]

Nesta Linha

 

if activecell.offset(0,1).value = "X" then

 

troque o X Maiusculo por x minusculo que vai funcionar

 

 

[Felipe2791]

19 minutos atrás, CasaDoHardware disse:

Cometi um pequeno erro

 

Deveria ser assim

 

Range("A2").select 

 

Mas ja ajustei a macro a sua planilha é so copiar os codigos do modulo 1 e colar em um modulo de sua planilha original.

teste.xlsm

@CasaDoHardware

Eu fiz isso da outraz vez tambem, dessa maneira a varredura funciona.

Mas o email não é gerado no Display.

[Basole]

@Felipe2791Segue em anexo com as adaptaçoes para voce testaar. 

Não testei pois nao tenho o outlook habilitado. 

 

* Só um detalhe dependendo do servidor de email (por exemplo o Gmail), nao vai 'deixar' voce enviar emails em massa. 

Pelo menos para mim aconteceu. Tenten a algum tempo atras, enviar emails 'por atacado' e o Gmail me bloqueou alegando spam. 

 

 

 

 

teste-Basole.xlsm

[Felipe2791]

8 minutos atrás, Basole disse:

@Felipe2791Segue em anexo com as adaptaçoes para voce testaar. 

Não testei pois nao tenho o outlook habilitado. 

 

* Só um detalhe dependendo do servidor de email (por exemplo o Gmail), nao vai 'deixar' voce enviar emails em massa. 

Pelo menos para mim aconteceu. Tenten a algum tempo atras, enviar emails 'por atacado' e o Gmail me bloqueou alegando spam. 

 

 

 

 

teste-Basole.xlsm

 

@Basole Não vou ter esse problema, o servidor é particular.

Um detalhe, o codigo está repetindo somente o primeiro email, não percorre a planilha. voce pode comprovar o problema porque o texto "nome 1..." aparece em todos emails aberto.

 

 

[Basole]

Desculpe acrescente esta linha agentes da linha loop

Linha = linha + 1

[Felipe2791]

7 minutos atrás, Basole disse:

Desculpe acrescente esta linha agentes da linha loop

Linha = linha + 1

@Basole Adicionei, ele envia 2 em sequencia e para.

[Basole]

Desculpe, acho que me equivoquei na orientacao acima.

 

Segue em anexo c/ as alteraçoes

 

teste-Basole-v1.xlsm

[Felipe2791]

39 minutos atrás, Basole disse:

Desculpe, acho que me equivoquei na orientacao acima.

 

Segue em anexo c/ as alteraçoes

 

teste-Basole-v1.xlsm

@Basole Para minha necessidade vai funcionar muito, mas tem um detalhe, quando ele encontra um problema (linha sem X) ele para e não "pula" para a proxima com X.

 

Eu vou usar a lista toda sempre, então tá tranquilo.

 

EDIT: Pensando bem, se tivesse como resolver esse problema eu agradeceria, pode ser que eu use.

[CasaDoHardware]

você testou a alteração que postei????

Nesta Linha

 

if activecell.offset(0,1).value = "X" then

 

troque o X Maiusculo por x minusculo que vai funcionar

 

[Felipe2791]

14 minutos atrás, CasaDoHardware disse:

você testou a alteração que postei????

Nesta Linha

 

if activecell.offset(0,1).value = "X" then

 

troque o X Maiusculo por x minusculo que vai funcionar

 

Testei sim, não pasou, ele faz a varredura mas não dispara email

[CasaDoHardware]

Digite x na celula A7 e faça o seguinte:

 

Abra o Editor VBA 

 

No codigo enviomassa depure o codigo e siga passo a passo ate a finalizar e diga se apresenta algum erro

 

Eu nao tenho como testar mas se seu codigo funciona tem que funcionar dessa forma porque quando você coloca x em A7 (serve qualquer celula da coluna A), ele aceita o if que criei como verdadeiro e executa a macro enviar que alterei o nome da sua para enviar.

 

você fez essa alteração na Planilha original trocou o nome da sua macro para enviar e colou ela em um modulo?

 

Veja que essa codigo faz somente isso 

 

Ele seleciona a coluna D e enquanto a coluna D nao estiver Vazia ele vai rodar 

O teste if verifica se a celula da coluna A tem um x se tiver executa a macro Enviar (sua macro com novo nome que deve se copiada e colada em um modulo), se nao existir um x na linha da coluna A ele simplesmente pula para a proxima, ate encontrar uma linha vazia na coluna D.

 

 

 

 

Sub EnvioMassa()
 

'Seleciona a primeira celula com email da coluna D 
Range("D7").Select
 

'Enquanto a nao encontrar uma celula Vazia na coluna D executa o que vem a seguir
Do While ActiveCell <> ""
 

Se a celula da linha ativa na coluna A existir um x
If ActiveCell.Offset(0, -3).Value = "x" Then
 

'Executa a macro Enviar (sua macro acima com o nome Private Sub Enviar () que esta no modulo com o arquivo que enviei)
Enviar
 Se nao
Else
 Pula uma linha
ActiveCell.Offset(1, 0).Select
 
 
End If
 
 Reinicia o codigo 
Loop
 
End Sub

 

então se você fez isso tudo conforme esta acima tem que funcionar.

[Felipe2791]

16 minutos atrás, CasaDoHardware disse:

Digite x na celula A7 e faça o seguinte:

 

Abra o Editor VBA 

 

No codigo enviomassa depure o codigo e siga passo a passo ate a finalizar e diga se apresenta algum erro

 

Eu nao tenho como testar mas se seu codigo funciona tem que funcionar dessa forma porque quando você coloca x em A7 (serve qualquer celula da coluna A), ele aceita o if que criei como verdadeiro e executa a macro enviar que alterei o nome da sua para enviar.

 

você fez essa alteração na Planilha original trocou o nome da sua macro para enviar e colou ela em um modulo?

 

Veja que essa codigo faz somente isso 

 

Ele seleciona a coluna D e enquanto a coluna D nao estiver Vazia ele vai rodar 

O teste if verifica se a celula da coluna A tem um x se tiver executa a macro Enviar (sua macro com novo nome que deve se copiada e colada em um modulo), se nao existir um x na linha da coluna A ele simplesmente pula para a proxima, ate encontrar uma linha vazia na coluna D.

 

 

 

 

Sub EnvioMassa()
 

'Seleciona a primeira celula com email da coluna D 
Range("D7").Select
 

'Enquanto a nao encontrar uma celula Vazia na coluna D executa o que vem a seguir
Do While ActiveCell <> ""
 

Se a celula da linha ativa na coluna A existir um x
If ActiveCell.Offset(0, -3).Value = "x" Then
 

'Executa a macro Enviar (sua macro acima com o nome Private Sub Enviar () que esta no modulo com o arquivo que enviei)
Enviar
 Se nao
Else
 Pula uma linha
ActiveCell.Offset(1, 0).Select
 
 
End If
 
 Reinicia o codigo 
Loop
 
End Sub

 

então se você fez isso tudo conforme esta acima tem que funcionar.

Eu tenteide tudo botar para funcionar, mas ele retornar a depuração no meu VBA, na linha: If Target.Address = "$A$" & linha Then

 

 

 

Private Sub Enviar()

'Envia e-mail pelo Outlook

    Dim OutApp As Object
    Dim OutMail As Object
    Dim texto As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    linha = ActiveCell.Row - 1
    If Target.Address = "$A$" & linha Then
    If Plan1.Cells(linha, 1) = "x" Then

        With OutMail
            .To = Plan1.Cells(linha, 4)
            .CC = ""
            .BCC = ""
            .Subject = "Nível"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 3) & "," & vbCrLf & vbCrLf & _
                    "Segue acompanhamento do mês de Julho."
                    
                    
            .Display    'Send para enviar o email sem abrir o Outlook
        End With
        On Error GoTo 0
        End If

        Set OutMail = Nothing
        Set OutApp = Nothing
        
    End If
    End Sub

[CasaDoHardware]

 

 

Tente apagar essa linha do erro e o ultimo end if que esta acima  do end sub

[Felipe2791]

8 minutos atrás, CasaDoHardware disse:

 

 

Tente apagar essa linha do erro e o ultimo end if que esta acima  do end sub

ela fica carregando (mesmo com 3 linhas ativas e 1 x) quando aperto ESC ele pede para depurar a linha seguinte.

[Basole]

O error aparece por causa do Target

Tente declarar o objeto desta forma:

Dim Target as range

 

[CasaDoHardware]

Na verdade tem que apagar essa variavel

 

Apague essa linha tb

[Felipe2791]

Em 21/03/2016 às 17:14, Basole disse:

O error aparece por causa do Target

Tente declarar o objeto desta forma:

Dim Target as range

 

@Basole Mesma coisa, Quando coloco o X apenas na segunda ele trava o Excel, se coloco nas 3 primeiras e pulo pra quinta, ele para de enviar na terceira.

 

Já tentei mas não consegui. 

 

Citação

Postado ontem às 17:32 · Denunciar post

Na verdade tem que apagar essa variavel

 

Apague essa linha tb

@CasaDoHardware O seu codigo não consegui colocar para funcionar de forma alguma, a parte dos rastreio da condição está perfeita, mas os emails não disparam, já eliminei tudo que pediu.

[Basole]

Bom dia,

Felipe segue em anexo com as correções: 

teste-Basole-v2.xlsm

[Felipe2791]

8 minutos atrás, Basole disse:

Bom dia,

Felipe segue em anexo com as correções: 

teste-Basole-v2.xlsm

 

@BasoleApareceu depuração na linha que indica o endereço de email:

 

.To = Plan1.Cells(linha, 4)