Jump to content
Fórum Script Brasil
  • 0

COMO ENVIAR EMAILS EM PLANILHA FILTRADA NO VBA?


BlobCat

Question

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 & "; [email protected]"
        ElseIf cc1 = "" And cc2 = "" Then
            .CC = "[email protected]"
        ElseIf cc1 <> "" And cc2 = "" Then
            .CC = cc1 & "; [email protected]"
        ElseIf cc1 = "" And cc2 <> "" Then
            .CC = cc2 & "; [email protected]"
        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 to post
Share on other sites

8 answers to this question

Recommended Posts

  • 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 to post
Share on other 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...

Edited by BlobCat
Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



  • Forum Statistics

    • Total Topics
      148691
    • Total Posts
      644530
×
×
  • Create New...