wagnerjahu

Pessoal, sou iniciante em programação. Peço uma ajuda de vocês! Preciso automatizar um processo que toma muito meu tempo. Tenho uma arquivo onde tem 2 planilhas (Dados e Tabela1) que preciso enviar 3 vezes por semana. A planilha Dados vem com informações de vários departamentos e preciso filtrar e salvar em arquivos individualmente e depois enviar esses arquivos separados para cada destinatário da lista, no final marcar na coluna $i se foi enviado ou deu erro, para que tenha um controle. Não fiz tratamento da possibilidade de o dado da planilha Dados não existir na planilha Tabela1. Na planilha Dados tenho os critérios para filtrar, determino os nomes de arquivos que deverão ser salvos, e-mails, nome dos responsáveis, também devo colocar um assunto e uma mensagem no e-mail, que deve anexar o arquivo salvo anteriormente. Não estou conseguindo passar o conteúdo de tabela Dados (departamento) para filtrar a Tabela1 (dados brutos), está parando na instrução abaixo: "wsTabela.ListObjects("Tabela1").Range.AutoFilter Field:=7, Criteria1:=cell.Value" Também não sei se chegou até o final do código sem outros erros, pois parei no primeiro erro e não consegui avançar. Segue em anexo um modelo de planilha para realizar essas operações. Sub EnviarEmails() Dim wsDados As Worksheet Dim wsTabela As Worksheet Dim OutApp As Object Dim OutMail As Object Dim rng As Range Dim fileName As String Dim cell As Range Dim valorCelula As String ' Defina as planilhas de trabalho Set wsDados = ThisWorkbook.Sheets("Dados") Set wsTabela = ThisWorkbook.Sheets("Tabela1") ' Loop através das linhas na planilha Dados For Each cell In wsDados.Range("D2:D" & wsDados.Cells(wsDados.Rows.Count, "D").End(xlUp).Row) ' Copie o valor da célula D2 para filtrar a Tabela1 wsTabela.ListObjects("Tabela1").Range.AutoFilter Field:=7, Criteria1:=cell.Value ' Copie todos os dados filtrados Set rng = wsTabela.ListObjects("Tabela1").DataBodyRange.SpecialCells(xlCellTypeVisible) ' Crie um novo arquivo Excel Workbooks.Add ' Cole os dados no novo arquivo rng.Copy ThisWorkbook.Sheets(1).Range("A1") ' Defina o nome do arquivo e diretório fileName = wsDados.Range("C2").Value & "\" & wsDados.Range("E2").Value & ".xlsx" ' Salve o arquivo ActiveWorkbook.SaveAs fileName ' Feche o novo arquivo ActiveWorkbook.Close ' CHAMAR O THUNDERBIRD Dim thund As String Dim email As String Dim CC As String Dim BCC As String Dim subj As String Dim body As String Dim Attch As String Dim oRngToCopy As Range email = wsDados.Range("G2").Value CC = "[email protected]" BCC = "[email protected]" subj = "Testing" body = "Testing" Attch = fileName thund = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe\thunderbird.exe " & _ "-compose " & """" & _ "to='" & email & "'," & _ "cc='" & CC & "'," & _ "bcc='" & BCC & "'," & _ "subject='" & subj & "'," & _ "message='" & Attch & "'," & _ "body='" & body & "'" & """" ' ALTERE * ABAIXO O TEMPO DE ESPERA, SE NECESSARIO: Call Shell(thund, vbNormalFocus) Application.Wait (VBA.Now + VBA.TimeValue("0:00:09")) ' 9 seg.* VBA.SendKeys "^v", True ' cola na janela do corpo do email Application.Wait (VBA.Now + VBA.TimeValue("0:00:03")) ' 3 seg. * VBA.SendKeys "^{ENTER}", True ' Preencha a célula I2 com "Enviado" wsDados.Range("I2").Value = "Enviado" ' Limpe o filtro na Tabela1 wsTabela.ListObjects("Tabela1").AutoFilter.ShowAllData Next cell ' Limpe o filtro final wsTabela.ListObjects("Tabela1").AutoFilter.ShowAllData End Sub Enviar_Semana2.xlsx