BlobCat

Onde exatamente ele entraria no código? No If do "With OutMail"? Eu precisaria comentar ou retirar alguma linha do código? Desculpa por tantas perguntas, essa parte da planilha está me dando tanta dor de cabeça.

Acabaria sendo mais trabalhoso, justo pela planilha conter tantas linhas. Utilizando o filtro dos títulos, qualquer pessoa que fosse usar essa planilha, conseguiria enviar apenas para aqueles que ela quisesse.

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

Sim, no caso, quando eu filtrasse a coluna M por "PENDENTE", eu gostaria que ele enviasse emails apenas para aquelas linhas filtradas, que estão aparecendo. Só não sei como mandar o VBA fazer isso.

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