luiza lopes

os dados não são excluídos! Como faço para marcar a linha da planilha BD, não entendi direito, poderia me explicar?

Enviei pelo e-mail! Obrigadaaa @Alyson Ronnan Martins

Boa noite, @Alyson Ronnan Martins! Estava aplicando o código e acabou surgindo um problema que não sei resolver. Ao adicionar uma nova tabela na aba "Dados" e Transpor as colunas para a aba "Lista", o código replica toda a informação existente e adiciona a nova linha da última tabela. Ao invés de apenas adicionar a nova linha. Por exemplo: vamos supor que esse é um exemplo da minha aba Dados: bola, caneta, lápis, carrinho e quero adicionar o elemento joão, o código está fazendo isso: bola, caneta, lápis, carrinho,bola, caneta, lápis, carrinho, joão. E o que eu precisava seria:bola, caneta, lápis, carrinho,joão. Alguma ideia de como posso resolver esse problema? Vou enviar o código novamente com as alterações que fiz para se adaptar ao q eu precisava: <>Option Explicit Sub TransporDados() Dim uLinha As Long 'Última linha Dim lLista As Long 'Linha nova na tabela Lista Dim cLista As Long 'Coluna nova na tabela lista Dim yLista As Long 'Coluna pesquinsando a lista Dim g As Long 'Grupo do produto Dim x As Long 'Linha Dim y As Long 'Coluna Dim txtCampo Dim txtValor Application.ScreenUpdating = False Application.Calculation = xlCalculationManual uLinha = Sheets("BD").Cells(Rows.Count, "A").End(xlUp).Row For g = 1 To uLinha Step 10 'Ultima linha da lista lLista = Sheets("Análise de Dados").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Loop pulando de 2 em 2 começando na coluna 2 até 6 For y = 2 To 6 Step 2 'Loop para passar pelas linhas For x = g To g + 9 txtCampo = Sheets("BD").Cells(x, y - 1).Value2 txtValor = Sheets("BD").Cells(x, y).Value2 'Procurar a coluna para colocar o valor For yLista = 1 To 31 Step 1 If Sheets("Análise de Dados").Cells(1, yLista).Value = txtCampo Then cLista = yLista yLista = 32 'Parar o for End If Next yLista 'Cadastrar o valor na tabela nova Sheets("Análise de Dados").Cells(lLista, cLista).Value = txtValor Next Next y Next g Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

DEU CERTO!!!! UHU MUITO OBRIGADA. Tem algo que eu possa fazer pra te ajudar?

Não entendi, poderia escrever onde está errado, por favor? Eu mudei o nomes das abas para "BD" e "Análise de Dados"

Bom dia, fico no aguardo @Alyson Ronnan Martins!

Boa noite, @Alyson Ronnan Martins .Consegui arrumar! Agora surgiu outra duvida. Estou adaptando o seu codigo para o meu no entando a tabela que estou usando é um pouco diferente e resultou em quatro linhas que ele não identifica. Sabe me dizer qual seria o problema? Essa é a nova tabela que estou usando Os dados transpostos ficam assim: E terminam na coluna 31. Todos ficaram corretos menos os de Volume Terra, Volume Bordo e Inspeção na Barra que ficaram em branco! Sabe me dizer o porque? Seu código que alterei: <> Sub cmdImportarTexto() Dim uLinha As Long 'Última linha Dim lLista As Long 'Linha nova na tabela Lista Dim cLista As Long 'Coluna nova na tabela lista Dim yLista As Long 'Coluna pesquinsando a lista Dim g As Long 'Grupo do produto Dim x As Long 'Linha Dim y As Long 'Coluna Dim txtCampo Dim txtValor Application.ScreenUpdating = False Application.Calculation = xlCalculationManual uLinha = Sheets("BD").Cells(Rows.Count, "A").End(xlUp).Row For g = 2 To uLinha Step 10 'Ultima linha da lista lLista = Sheets("Análise de Dados").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Loop pulando de 2 em 2 começando na coluna 2 até 6 For y = 2 To 10 Step 2 'Loop para passar pelas linhas For x = g To g + 10 Step 1 txtCampo = Sheets("BD").Cells(x, y - 1).Value txtValor = Sheets("BD").Cells(x, y).Value 'Procurar a coluna para colocar o valor For yLista = 1 To 31 Step 1 If Sheets("Análise de Dados").Cells(1, yLista).Value = txtCampo Then cLista = yLista yLista = 32 'Parar o for End If Next yLista 'Cadastrar o valor na tabela nova Sheets("Análise de Dados").Cells(lLista, cLista).Value = txtValor Next Next y Next g Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

Simm, é bem isso que está acontecendo. o cLista fica vazio! Alguma ideia de como arrumar isso?

Primeiro, muito obrigada pela ajuda @Alyson Ronnan Martins! Agora, tentei rodar no meu computador mudando apenas o nome das abas e aparece isso: Nessa linha aqui, alguma ideia para resolver esse problema?

Claro! vou te mandar a tabela sem preencher que fica mais claro: Essa é a tabela, o esquema é cada pessoa vai preencher ela de modo diferente e preciso transpor essas informações para outra aba. As informações que quero transpor são aquelas que as pessoas vão preencher ( espaço em branco). Veja se ficou mais claro agora! E as informações tem que ficar assim na outra aba @Alyson Ronnan Martins

Exatamente isso! O problema é que as colunas que preciso as informações são mescladas. Tipo preciso só das informações das linhas 2, 4 e 6 e essas informações fariam de 7 em 7 linhas.

Sim, serão 7 informações preenchidas. Mas só as informações da 2,4 e 6 colunas que devem ser transpostas na outra aba. Como se fosse assim: Essa foto é da aba com as informações transpostas já

Os valores que nunca mudam são os da coluna 1, 3 e 5. A tabela original seria essa e funcionaria de modo que cada vez uma pessoa diferente iria preencher os dados com valores diferentes. E agora eu preciso transpor esses dados para colunas diferentes porem na mesma aba. Me avise se ainda não ficou claro a ideia, por favor! Você está me ajudando mtu

Oii, então o código criado ficou mtu bom! Atende quase tudo o que eu preciso. Vou tentar te explicar melhor o que acontece com a tabela usando valores diferentes. Vou mandar os prints aqui. As duas figuras são em abas diferentes. Antes eu usei "Nome do Produto" como exemplo, agora acho que com esse exemplo ficou mais claro. Obrigada desde jaaa Oii, então o código criado ficou mtu bom! Atende quase tudo o que eu preciso. Vou tentar te explicar melhor o que acontece com a tabela usando valores diferentes. Vou mandar os prints aqui. As duas figuras são em abas diferentes. Antes eu usei "Nome do Produto" como exemplo, agora acho que com esse exemplo ficou mais claro. Obrigada desde jaaa. Creio que só falte adicionar um loop das informações e colocar todas na mesma aba.

Certo, muito obrigada!

Não consigo enviar a planilha por aqui. Estou enviando como eu gostaria que ficasse. A primeira figura estaria em uma aba denominada "BD" e a Segunda em outra aba com nome " Análise de Dados". @Alyson Ronnan Martins por favor me avise caso precise de mais alguma informação

@Alyson Ronnan Martins

Vou testar ainda! É que eu tinha outra dúvida também, de como juntar as três macros que eu uso para transpor dados em uma. Você acha que teria como? A tabela que eu uso é essa aqui: e cada coluna em branco eu uso uma macro para transpor cada linha individual em uma coluna. O código é o mesmo que enviei

certo! e quanto a outra macro de repor todas as linhas nas colunas em uma só, alguma ideia de como posso fazer isso?

sim, e outra coisa é que são varias linhas e por isso uso uma macro para transpor cada uma em uma coluna diferente. Teria como um único código transpor todas de uma vez só? Essa tabela é só um representativo do que estou transportando. As colunas possuem parâmetros diferentes

Oii @Alyson Ronnan Martins tentei fazer isso mas aparentemente está demorando mais que antes, mais alguma sugestão? 🙂

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

Então o código retorna uma data diferente do dia atual, e creio que isso esteja vinculado a esta linha aqui "Dim outMail As Outlook.MailItem 'Variável do objeto e-mail" desabilitada por problemas de variável. Porém não sei como arrumar. Segue o código e o problema da linha: <>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

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