Ir para conteúdo
Fórum Script Brasil
  • 0

COMO ENVIAR EMAILS EM PLANILHA FILTRADA NO VBA?


BlobCat

Pergunta

Pessoal, preciso de ajuda em algo que parece relativamente fácil, mas estou há dias quebrando a cabeça. Eu tenho uma planilha que uso para disparar emails para alguns contatos. Quando não recebo o comunicado deles, os status da minha planilha mudam para "PENDENTE". Eu gostaria, que essa planilha, enviasse os emails apenas para as linhas que aparecessem depois que eu filtrasse, mas ele acaba mandando para as que estão ocultas também. E para mim, não é útil que eu faça um filtro usando a palavra "PENDENTE". Gostaria que funcionasse, filtrando normalmente pela linha de títulos. Segue abaixo o código que utilizei e alguns prints da planilha.

Sub EnviarEmails()

    Application.ScreenUpdating = False
    Dim xWb As Workbook
    Dim Arquivo As String
    Dim receiver As String
    Dim cc1 As String
    Dim cc2 As String

    
    Arquivo = ActiveWorkbook.Name
    
    linha_inicial = 2
    linha = linha_inicial
    
    Do Until Workbooks(Arquivo).Sheets("2019").Cells(linha, 13) = ""
    linha = linha + 1
    Loop
    
    Size = linha - 2
    ReDim Nome(Size) As Variant
        
    
    linha = linha_inicial
    i = 0
    Do Until Sheets("2019").Cells(linha, 13) = ""
        Nome(i) = Sheets("2019").Cells(linha, 9)
        linha = linha + 1
        i = i + 1
    Loop
    
    x = RemoveDupesColl(Nome)
    
    For i = LBound(x) To UBound(x) - 1
        
        
        receiver = WorksheetFunction.VLookup(x(i), Workbooks(Arquivo).Sheets("2019").Range("I:M"), 2, False)
        cc1 = WorksheetFunction.VLookup(x(i), Workbooks(Arquivo).Sheets("2019").Range("I:M"), 3, False)
        cc2 = ""
                
        Workbooks(Arquivo).Activate
        Workbooks(Arquivo).Sheets("2019").Range("$A$" & linha_inicial - 1 & ":$M$100000").AutoFilter Field:=9, Criteria1:=x(i)
        Workbooks(Arquivo).Sheets("2019").Range("$B$" & linha_inicial - 1 & ":$M$100000").Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
        
        Nome = "Controle - " & x(i) & ".xlsx"
        Set xWb = Workbooks.Add
        With xWb
            .Activate
            .Sheets("Planilha1").Paste
            .Sheets("Planilha1").Columns("A:Z").EntireColumn.AutoFit
            .Sheets("Planilha1").Range("A1").Select
            .SaveAs Filename:=Nome
            Call SendWorkbook(receiver, xWb, cc1, cc2)
            n = xWb.FullName
            .Close
            Kill (n)
        End With
        
    Next i
    
    Workbooks(Arquivo).Activate
    Workbooks(Arquivo).Sheets("2019").Range("$A$1:$M$100000").AutoFilter Field:=9
    Workbooks(Arquivo).Sheets("2019").Range("$A$1").Select
        
    Application.ScreenUpdating = True
End Sub

Sub SendWorkbook(receiver As String, xWb As Workbook, complemento As String, Optional cc1 As String, Optional cc2 As String)
    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next
    With OutMail
        .To = receiver
        
        cc1 = Replace(cc1, " ", "")
        cc2 = Replace(cc2, " ", "")
        
        If cc1 <> "" And cc2 <> "" Then
            .CC = cc1 & " ; " & cc2 & "; fulano1@outlook.com"
        ElseIf cc1 = "" And cc2 = "" Then
            .CC = "fulano1@outlook.com"
        ElseIf cc1 <> "" And cc2 = "" Then
            .CC = cc1 & "; fulano1@outlook.com"
        ElseIf cc1 = "" And cc2 <> "" Then
            .CC = cc2 & "; fulano1@outlook.com"
        End If
        
        
        .BCC = ""
        .Subject = "TESTE"
        '.Body = "TESTE 2"
        
        .Body = "TESTE 3"
        .Attachments.Add xWb.FullName
        .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

Function RemoveDupesColl(MyArray As Variant) As Variant
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray)
        arrDummy1(i) = CStr(MyArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function

 

Print1.png

Print3.png

Link para o comentário
Compartilhar em outros sites

8 respostass a esta questão

Posts Recomendados

  • 0

Bom com esse comando você manda para caso a luminha seja vazia.

linha = linha_inicial
    i = 0
    Do Until Sheets("2019").Cells(linha, 13) = ""
        Nome(i) = Sheets("2019").Cells(linha, 9)
        linha = linha + 1
        i = i + 1
    Loop

Ai a cima ele olha na coluna 13 

Tenta alterar assim

xLinhas = Sheets("SuaPlanilha").cells(Rows.count, "M").end(xlup).row

for x = 2 to xLinhas step 1
   if Sheets("SuaPlanilha").cells(x, "M").value = "Pendente"
     'aqui o comando para enviar o email
   end if
next x

Olha se consegue compreender

Link para o comentário
Compartilhar em outros sites

  • 0

Desculpe, acho que me expressei mal. Adicionando essa linha, ele vai filtrar pela palavra "PENDENTE". E eu estaria usando o filtro que está na linha dos titulos. Dessa maneira, se eu quisesse mandar para as linhas A2 e A4 apenas (filtrando qualquer um dos campos dos títulos), ele enviaria, sem selecionar e enviar para o endereço de email na linha A3 que estaria oculta, devido ao filtro. Mas com esse código quando eu tento enviar a planilha filtrada, ele envia sequencialmente para a A2, A3 e A4, mesmo com a planilha filtrada e a linha A3 oculta. Originalmente, a planilha tem cerca de 60 linhas, fazendo o filtro, eu mandaria para linhas aleatórias ex: 3, 5, 7, 11, 23, 43...

Editado por BlobCat
Link para o comentário
Compartilhar em outros sites

Participe da discussão

Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.

Visitante
Responder esta pergunta...

×   Você colou conteúdo com formatação.   Remover formatação

  Apenas 75 emoticons são permitidos.

×   Seu link foi incorporado automaticamente.   Exibir como um link em vez disso

×   Seu conteúdo anterior foi restaurado.   Limpar Editor

×   Você não pode colar imagens diretamente. Carregar ou inserir imagens do URL.



  • Estatísticas dos Fóruns

    • Tópicos
      152k
    • Posts
      651,8k
×
×
  • Criar Novo...