Como Transpor uma linha em uma coluna - Excel

Question

Bom dia gente preciso de um help...faz muito tempo que não mexo no vba do excel e acabei meio que esquecendo...Bom preciso aqui no serviço de uma macro que mude o conteúdo de uma linha para colunas. Segue print que mostra como esta e como preciso que esteja.

como e :

como preciso que seja:

 

Answer 1

Cara, se puder ser ficar assim fica bem mais fácil

O que acha?

Answer 2

Eu sei q e bem mais facil, mas preciso desse formato pq eu importo ela no c# !

Answer 3

execute essa macro e veja se funciona., Poste o resultado

 

Sub TranspoeColuna()

 

    Dim Celula As Range

 

 

    Range("A600").End(xlUp).Offset(2, 0).Value = "PRODUTO"

    Range("A600").End(xlUp).Offset(0, 1).Value = "QTD"

    Range("A600").End(xlUp).Offset(0, 2).Value = "DATA"

 

    Set Celula = Range("A2")

 

    Do While Celula.Value <> ""

 

    Range(Celula.Offset(0, 1).Address & ":" & Celula.Offset(0, 100).End(xlToLeft).Address).Copy

 

    Range("B500").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

        False, Transpose:=True

 

    Range(Celula.Address).Copy

    Range(Range("A500").End(xlUp).Offset(1, 0).Address & ":" & _

    Range("B500").End(xlUp).Offset(0, -1).Address).PasteSpecial

 

     Set Celula = Celula.Offset(1, 0)

 

    Range("B1:" & Range("B1").Offset(0, 500).End(xlToLeft).Address).Copy

 

    Range("C500").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

        False, Transpose:=True

 

    Loop

 

End Sub

Answer 4

Bom dia, esta macro na executa, da erro cara.

Answer 5

Qual erro?

Answer 6

Ola, aparece este erro:

 

Answer 7

Se vc copiou e colou del pode estar interpretando errado as quebrasd de linha, quando vc clica em debug qual linha ele mostra? Tente copiar e colar este novamente!

Repare que os valores A600 B500 são chutes do final da linha, vc deve alerar esses valores se suas linhas e colunas forem maiores que isso.

 

Sub TranspoeColuna()


    Dim Celula As Range

    Range("A600").End(xlUp).Offset(2, 0).Value = "PRODUTO"

    Range("A600").End(xlUp).Offset(0, 1).Value = "QTD"

    Range("A600").End(xlUp).Offset(0, 2).Value = "DATA"


    Set Celula = Range("A2")

 

    Do While Celula.Value <> ""

 

    Range(Celula.Offset(0, 1).Address & _
    ":" & Celula.Offset(0, 100). _
    End(xlToLeft).Address).Copy


    Range("B500").End(xlUp).Offset(1, 0). _
    PasteSpecial Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True


    Range(Celula.Address).Copy

    Range(Range("A500").End(xlUp). _
    Offset(1, 0).Address & ":" & _
    Range("B500").End(xlUp). _
    Offset(0, -1).Address).PasteSpecial


     Set Celula = Celula.Offset(1, 0)


    Range("B1:" & Range("B1").Offset(0, 500).End(xlToLeft).Address).Copy

    Range("C500").End(xlUp). _
    Offset(1, 0).PasteSpecial _
    Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

     Loop

 End Sub

Answer 8

Bom dia,

cara agora ta quase indo bem, fiz uns ajustes para que ele transpõe a tabela em outro sheet pq acredito que fique melhor agora seguem print de como ta ficando:

Tabela Base

Tabela alterada:

pode ver q ta fazendo o processo somente pelo primeiro produto, segue o código com evidenciada a parte que ta dando erro agora....

Sub TransporColunas2()


    Dim Celula As Range
    
    Sheets("NOVO_BP").Select

    'Range("A600").End(xlUp).Offset(2, 0).Value = "PRODUTO"
    'Range("A600").End(xlUp).Offset(0, 1).Value = "QTD"
    'Range("A600").End(xlUp).Offset(0, 2).Value = "DATA"
    
    Range("A1").Value = "PRODUTO"
    Range("B1").Value = "QTD"
    Range("C1").Value = "DATA"
    
    
    Sheets("BP").Select

    Set Celula = Range("A2")
    

    Do While Celula.Value <> ""

    Range(Celula.Offset(0, 1).Address & _
    ":" & Celula.Offset(0, 100). _
    End(xlToLeft).Address).Copy
    
    Sheets("NOVO_BP").Select
    
    Range("B500").End(xlUp).Offset(1, 0). _
    PasteSpecial Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    
    Sheets("BP").Select

    Range(Celula.Address).Copy
    
    Sheets("NOVO_BP").Select

    Range(Range("A500").End(xlUp). _
    Offset(1, 0).Address & ":" & _
    Range("B500").End(xlUp). _
    Offset(0, -1).Address).PasteSpecial
    
    Sheets("BP").Select

    Set Celula = Celula.Offset(1, 0)

    Range("B1:" & Range("B1").Offset(0, 500).End(xlToLeft).Address).Copy 'DA PROBLEMA NESSA LINHA
    
    Sheets("NOVO_BP").Select

    Range("C500").End(xlUp). _
    Offset(1, 0).PasteSpecial _
    Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

     Loop

 End Sub

te agradeço por estar me ajudando...acredito que agora e só um detalhe né ?!

Fico no aguardo.

Vlw

Answer 9

fiz uns testes, alterei algumas linhas, aki agora tá funcionando. copia e cola, execute e informa se deu certo. Caso de algum erro, informa qual erro está dando e qual linha.

Sub TransporColunas2()


    Dim Celula As Range
    Dim UltimaLinha As Long
    Dim UltimaColuna As Integer
    
    
    Sheets("NOVO_BP").Select

    'Range("A600").End(xlUp).Offset(2, 0).Value = "PRODUTO"
    'Range("A600").End(xlUp).Offset(0, 1).Value = "QTD"
    'Range("A600").End(xlUp).Offset(0, 2).Value = "DATA"
    
    Range("A1").Value = "PRODUTO"
    Range("B1").Value = "QTD"
    Range("C1").Value = "DATA"
    
    
    Sheets("BP").Select

    Set Celula = Range("A2")
    

    Do While Celula.Value <> ""
    
    Sheets("BP").Select
    
    UltimaColuna = Columns.Count - 1
    
    Range(Celula.Offset(0, 1).Address & _
    ":" & Celula.Offset(0, UltimaColuna). _
    End(xlToLeft).Address).Copy
    
    Sheets("NOVO_BP").Select
    
    UltimaLinha = Rows.Count - 1
    
    Range("B" & UltimaLinha).End(xlUp).Offset(1, 0). _
    PasteSpecial Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    
    Sheets("BP").Select

    Celula.Copy
    
    Sheets("NOVO_BP").Select

    Range(Range("A" & UltimaLinha).End(xlUp). _
    Offset(1, 0).Address & ":" & _
    Range("B" & UltimaLinha).End(xlUp). _
    Offset(0, -1).Address).PasteSpecial
    
    Sheets("BP").Select

    Set Celula = Celula.Offset(1, 0)

    Range("B1:" & Range("B1").Offset(0, UltimaColuna - 1).End(xlToLeft).Address).Copy 'DA PROBLEMA NESSA LINHA
    
    Sheets("NOVO_BP").Select

    Range("C" & UltimaLinha).End(xlUp). _
    Offset(1, 0).PasteSpecial _
    Paste:=xlPasteAll, _
    Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

     Loop

 End Sub

 

Answer 10

Valeu robatsilva , cara rodou certinho !!! Muito Obrigado.

Answer 11

Galera,

Fiz de uma forma mais consolidada.

Caso queiram mais de uma solução:

Sub Transpor()

Plan2.Cells(1, 1).Value = "Produto"
Plan2.Cells(1, 2).Value = "QTD"
Plan2.Cells(1, 3).Value = "Data"

I = 2
k = 2
Z = 2
While Plan1.Cells(I, 1).Value <> ""
    J = 2
    While Plan1.Cells(I, J).Value <> ""
        Plan2.Cells(Z, 1).Value = Plan1.Cells(I, 1).Value
        Plan2.Cells(Z, 2).Value = Plan1.Cells(I, J).Value
        Plan2.Cells(Z, 3).Value = Plan1.Cells(1, J).Value
        
        J = J + 1
        Z = Z + 1
    Wend
    I = I + 1
Wend

MsgBox "Operação Feita com sucesso!", vbInformation, "Informação"

End Sub

Answer 12

Karaka, muito ninja.

Answer 13

Prezado Robatsilva,

Parabéns pelo trabalho. De fato não ajudou, tão somente, o colega que postou a dúvida, mas, a mim também.

Eu queria aproveitar esta postagem para fazer uma pergunta. Pode ser que seja uma coisa tranquila, mas, como não sou desenvolvedor e não conheço a lógica do VBScript, prefiro pedir ajuda aos "universitário".

Pois bem, como eu faria para, ao invés de usar 3 colunas para receber os resultados eu usasse 4? Que tipo de alterações deveriam ser feitas no código?

Por exemplo: ao invés de termos PRODUTO, QTD, DATA; Teríamos PRODUTO, MARCA, QTD, DATA e assim por diante. Que trecho do código preciso editar para, inclusive, incluir mais colunas no BD produzido a partir da transposição?

Antecipadamente agradeço.

Wisley Velasco

Answer 14

Prezado Fabio Rhein,

Primeiramente parabéns pelo trabalho. De fato ajudou, não só o colega que postou a dúvida, mas, a mim também.

Eu queria aproveitar a pergunta que fiz para o Robatsilva e fazer a mesma pergunta pra você. Pode ser que seja uma coisa tranquila, mas, como não sou desenvolvedor e não conheço a lógica do VBScript, prefiro pedir ajuda aos "universitário".

É o seguinte, como eu faria para, ao invés de usar 3 colunas para receber os resultados eu usasse 4? Que tipo de alterações deveriam ser feitas no seu código?

Por exemplo: ao invés de termos PRODUTO, QTD, DATA; Teríamos PRODUTO, MARCA, QTD, DATA e assim por diante. Que trecho do código preciso editar para, inclusive, incluir mais colunas no BD produzido a partir da transposição?

Antecipadamente agradeço.

Wisley Velasco

Answer 15

Existe uma forma bem fácil de se fazer isso.

(considere a tabela da primeira postagem deste tópico)

1 - Selecione o intervalo A1:L4 e pressione Ctrl+C

2 - Selecione o intervalo A6:D17

3 - Digite a fórmula =TRANSPOR(A1:L4) e pressione Ctrl+Shift+Enter.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 16

Prezado Felipe Costa (Benzadeus)

Sua dica é interessante e prática. Todavia, transpor, simplesmente, as colunas em linhas, não resolve a minha necessidade e não fica igual ao resultado do exemplo do início do post. Se você reparar, a coluna "produto" não é transposto, pois é a referência dos registros.

De qualquer forma, muitíssimo obrigado por sua disposição em contribuir comigo e com os demais que farão uso destes posts.

Abraços.

Wisley Velasco