luiza lopes
-
Total de itens
24 -
Registro em
-
Última visita
Posts postados por luiza lopes
-
-
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 listaDim g As Long 'Grupo do produto
Dim x As Long 'Linha
Dim y As Long 'ColunaDim txtCampo
Dim txtValorApplication.ScreenUpdating = False
Application.Calculation = xlCalculationManualuLinha = 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 gApplication.ScreenUpdating = True
Application.Calculation = xlCalculationAutomaticEnd 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 linhaDim lLista As Long 'Linha nova na tabela Lista
Dim cLista As Long 'Coluna nova na tabela lista
Dim yLista As Long 'Coluna pesquinsando a listaDim g As Long 'Grupo do produto
Dim x As Long 'Linha
Dim y As Long 'ColunaDim txtCampo
Dim txtValorApplication.ScreenUpdating = False
Application.Calculation = xlCalculationManualuLinha = 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 gApplication.ScreenUpdating = True
Application.Calculation = xlCalculationAutomaticEnd 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
-
-
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çõesDim 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
TRANSPOR COLUNAS EM LINHAS
em VBA
Postado
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?