Ir para conteúdo
Fórum Script Brasil
  • 0

TRANSPOR COLUNAS EM LINHAS


luiza lopes

Pergunta

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


 

Link para o comentário
Compartilhar em outros sites

Posts Recomendados

  • 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
 

Editado por luiza lopes
Link para o comentário
Compartilhar em outros 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

                                                                                                           

Link para o comentário
Compartilhar em outros 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.

Editado por Alyson Ronnan Martins
Melhor formatação para identificação
Link para o comentário
Compartilhar em outros 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
...

 

Link para o comentário
Compartilhar em outros sites

Participe da discussão

Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.

Visitante
Responder esta pergunta...

×   Você colou conteúdo com formatação.   Remover formatação

  Apenas 75 emoticons são permitidos.

×   Seu link foi incorporado automaticamente.   Exibir como um link em vez disso

×   Seu conteúdo anterior foi restaurado.   Limpar Editor

×   Você não pode colar imagens diretamente. Carregar ou inserir imagens do URL.



  • Estatísticas dos Fóruns

    • Tópicos
      152k
    • Posts
      651,7k
×
×
  • Criar Novo...