TRANSPOR COLUNAS EM LINHAS

[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

 

[Alyson Ronnan Martins]

Bom dia @luiza lopes.

Teria como olhar se o valores lLista e cLista estão ficando vazios?

Deve ser essa a causa do de ficar com o erro cadastrar.

 

[luiza lopes]

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

 

[luiza lopes]

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
 

Editado Março 21, 2020 por luiza lopes

[luiza lopes]

Bom dia, fico no aguardo @Alyson Ronnan Martins!

[Alyson Ronnan Martins]

Boa tarde.

Verifique que o nome do "Rótulo da linha conha " na planilha lista não esta com o mesmo nome da tabela que é importada.

Tenta copiar o nome do rótulo e colocar para verircar se passa as informações.

[luiza lopes]

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

[Alyson Ronnan Martins]

Exemplo:

Coluna G
Volume terra / Total Discharged <> Volume Terra / Total Discharged

poder ser letras maiuscula e minuscolas, também podendo ser espaços

[luiza lopes]

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

 

[Alyson Ronnan Martins]

Fico feliz que tenha dado certo.

[luiza lopes]

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

                                                                                                           

[Alyson Ronnan Martins]

Bom dia.

Teria como mandar a planilha para eu dar uma olhada pois ficou ainda um pouco confuso entender o problema:

Se tiver dificuldade de mandar pelo site manda no meu e-mail: alysonronnan@gmail.com

[luiza lopes]

Enviei pelo e-mail! Obrigadaaa @Alyson Ronnan Martins

[Alyson Ronnan Martins]

@luiza lopes Olhei agora a planilha e o código esta certo. Precisa então mudar a "lógica" para então mudar o código.

Os dados da tabela "BD" não são excluidos depois que são colocados na tabela Análise de Dados?

Se não: Precisa marcar a linha da planiliha BD, podendo usar a coluna "G" para isso, para não lançar tudo novamente na próxima atualização.

Se Sim: Resolve o problema de ter dados duplicados.

 

Aguardo.

Editado Março 25, 2020 por Alyson Ronnan Martins
Melhor formatação para identificação

[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? 

 

 

[Alyson Ronnan Martins]

...
For g = 1 To uLinha Step 10
	...
Next g
...

Esse código acima é o loop "g" para separa a informações por linha então você pode olhar a Coluna "G" para ver se tem dados dentro dela e se sim pular esse dados:

...
For g = 1 To uLinha Step 10
	if Sheets("BD").Cells(g, "G").value = "x" then 'Estou usando "x" para marcar que já foi transferido
    	'Não faz nada
    Else 'Caso seja diferênte leve as informações para planilha Análise
    	
    	... 'Aqui código antigo
        
        'Agora entra a parte que vai marcar a linha
        Sheets("BD").Cells(g, "G").value = "x"
    end if

Next g
...