Jump to content
Fórum Script Brasil
  • 0
luiza lopes

TRANSPOR COLUNAS EM LINHAS

Question

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


 

Share this post


Link to post
Share on other sites

Recommended Posts

  • 0

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

image.png.7731bab8adee9a0e244517f4cc42dcae.png

Os dados transpostos ficam assim:

image.thumb.png.3d25b3dc7a61ebd2f3e1f5c97aea279a.png

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
 

Edited by luiza lopes

Share this post


Link to post
Share on other sites
  • 0

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

                                                                                                           

Share this post


Link to post
Share on other sites
  • 0

@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.

Edited by Alyson Ronnan Martins
Melhor formatação para identificação

Share this post


Link to post
Share on other sites
  • 0
...
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
...

 

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.




  • Forum Statistics

    • Total Topics
      148121
    • Total Posts
      643415
×
×
  • Create New...