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