luiza lopes

Olá, Eu uso essa macro para transpor linhas em colunas, mas vejo que com a adição de mais linhas ela fica cada vez mais lenta. Alguém teria uma solução para isso? De modo que a macro pegasse somente as informações das linhas mais atuais? <> Sub TransporDados1() 'Declarações Dim Arr() As Variant Dim LastRow As Variant, j As Long, linha As Long, coluna As Long Dim ws1 As Worksheet, ws2 As Worksheet Application.ScreenUpdating = False 'Declara a planilha com os dados Set ws1 = ThisWorkbook.Sheets("BD") Set ws2 = ThisWorkbook.Sheets("Análise de Dados") 'Em ws1: With ws1 'ÚltimaLinha LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'Array Arr() = .Range("B2:B" & LastRow).Value2 linha = 2 coluna = 1 'Loop em cada elemento da Array For j = LBound(Arr) To UBound(Arr) ws2.Cells(linha, coluna) = Arr(j, 1) coluna = coluna + 1 'Quando preencher 9 células, passa para próxima linha e zera contador de coluna If coluna = 11 Then linha = linha + 1 coluna = 1 End If Next j End With Application.ScreenUpdating = True 'Call timer2 End Sub <>

Tenho esse código que extrai o conteúdo do corpo do email e coloca em uma planilha no excel. Até ontem ele estava funcionando, porém hoje ele apareceu que " Objeto não aceita essa propriedade ou método" na linha que está em vermelho. Se alguém por favor poderia me ajudar? <>Sub lerEmail() 'Ler o e-mail e copiar para o excel as informações na aba "BD" Application.DisplayAlerts = False 'Desabilitar alertas Application.ScreenUpdating = False 'Desabilitar atualização de tela ActiveWorkbook.Save 'Salvar planilha Dim outApp As Outlook.Application 'Variável da aplicação do outlook Dim outMapi As Outlook.MAPIFolder 'Variável de conexão com as pastas desejadas, acesso ao e-mail 'Dim outMail As Outlook.MailItem 'Variável do objeto e-mail Dim outHTML As MSHTML.HTMLDocument 'Variável HTML document Dim sh_capa, sh_bd As Worksheet 'Variáveis das abas do excel Set sh_capa = Sheets("Capa") 'Configura aba Capa Set sh_bd = Sheets("BD") 'Configura aba BD Dim pasta, subpasta, mover As String 'Variável pasta e subpasta outlook Dim num_email, num_db, i, j, k, l, m, num As Long 'Variáveis auxiliares Dim data As Date 'Variável da data de recebimento do e-mail pasta = sh_capa.Cells(6, "B").Value 'Configura pasta outlook subpasta = sh_capa.Cells(6, "C").Value 'Configura subpasta outlook mover = sh_capa.Cells(6, "D").Value 'Pasta destino On Error Resume Next 'Habilita tratamento de erros Set outApp = GetObject(, "OUTLOOK.APPLICATION") 'Tenta configurar a aplicação do outlook If (outApp Is Nothing) Then 'Se outlook não estiver aberto... Set outApp = CreateObject("OUTLOOK.APPLICATION") 'Configura a aplicação do outlook End If On Error GoTo 0 'Desabilita tratamento de erros Set outMapi = outApp.GetNamespace("MAPI").Folders(pasta).Folders(subpasta) 'Configura a variável de conexão com as pastas desejadas do outlook Set outHTML = New MSHTML.HTMLDocument 'Configura a variável HTML document para ler o corpo do e-mail 'Verifica se existem e-mails disponíveis na subpasta desejada If outMapi.Items.Count = 0 Then MsgBox "Não foram encontrados e-mails" Exit Sub 'Interrompe o programa caso não encontre e-mails na subpasta End If num_email = outMapi.Items.Count 'Quantidade de e-mails na subpasta 'Conta quantas linhas existem na aba "BD" para que os novos dados possam ser inseridos de forma sequencial num_db = sh_bd.Cells(Rows.Count, "A").End(xlUp).Row - 1 num = 0 ' Variável responsável por contar quantos e-mails serão salvos For i = 1 To num_email Set outMail = outMapi.Items(i - num) 'Configura a variável do e-mail atual e subtrai quantos e-mails já foram copiados, 'pois os e-mails são deletados da caixa de entrada 'Data de recebimento do e-mail data = DateSerial(Year(outMail.ReceivedTime), Month(outMail.ReceivedTime), Day(outMail.ReceivedTime)) 'Se satisfazer todas as condições definidas na capa, incluse a busca por remetente... If outMail.Subject Like "*" & sh_capa.Cells(9, "C").Value And _ outMail.SenderEmailAddress = sh_capa.Cells(10, "C").Value And _ data >= sh_capa.Cells(11, "C").Value And _ data <= sh_capa.Cells(12, "C").Value Then 'Recebe o codigo HTML correspondente ao corpo do e-mail outHTML.Body.innerHTML = outMail.HTMLBody 'Configura a variável para leitura da tabela recebida Set outTable = outHTML.getElementsByTagName("table") 'Copia os campos da tabela para o excel For x = 1 To outTable(0).Rows.Length - 1 For y = 0 To outTable(0).Rows(x).Cells.Length - 1 sh_bd.Cells(1 + num_db + x, 1 + y).Value = outTable(0).Rows(x).Cells(y).innerText Next y Next x 'Variável auxiliar para copiar os dados de forma sequencial num_db = num_db + outTable(0).Rows.Length - 1 'Conta quantos e-mails já foram salvos num = num + 1 'Move o e-mail para a pasta de concluídos outMail.Move outApp.GetNamespace("MAPI").Folders(pasta).Folders(mover) 'Se satisfazer todas as condições definidas na capa, exceto a busca por remetente... ElseIf outMail.Subject Like "*" & sh_capa.Cells(9, "C").Value And _ sh_capa.Cells(10, "C").Value = "" And _ data >= sh_capa.Cells(11, "C").Value And _ data <= sh_capa.Cells(12, "C").Value Then 'Recebe o codigo HTML correspondente ao corpo do e-mail outHTML.Body.innerHTML = outMail.HTMLBody 'Configura a variável para leitura da tabela recebida Set outTable = outHTML.getElementsByTagName("table") 'Copia os campos da tabela para o excel For x = 1 To outTable(0).Rows.Length - 1 For y = 0 To outTable(0).Rows(x).Cells.Length - 1 sh_bd.Cells(1 + num_db + x, 1 + y).Value = outTable(0).Rows(x).Cells(y).innerText Next y Next x 'Variável auxiliar para copiar os dados de forma sequencial num_db = num_db + outTable(0).Rows.Length - 1 'Conta quantos e-mails já foram salvos num = num + 1 'Move o e-mail para a pasta de concluídos outMail.Move outApp.GetNamespace("MAPI").Folders(pasta).Folders(mover) End If Next i 'Se algum e-mail foi salvo... If num > 0 Then 'Mensagem apresentada para o usuário MsgBox "Processamento Concluído! " & num & " e-mail carregados!" sh_bd.Select Else 'Mensagem apresentada para o usuário MsgBox "Nenhum e-mail carregado!" End If 'Volta a exibir alertas Application.DisplayAlerts = True 'Volta a atualizar a tela Application.ScreenUpdating = True End Sub