How to transform multiple columns into 2 columns with vba?

Question

I have a spreadsheet with the following information.

I want to create a new sheet with some columns of this sheet and transform the columns Nominal, Humidity, Primeira_delivery, Degree Drink, Standard, Medicinal and Restr_horario in a column called ITEM and the value of these columns in another column called FLAG.

My new spreadsheet would look like this:

I also want to create the N_ITEM column which is based on the value of the ITEM column.

If Item = STANDARD then N_ITEM = 1,

If Item = NOMINAL, MOISTURE, GRAU_BEBIDA, MEDICINAL then N_ITEM = 2

If Item = PRIMEIRA_ENTREGA then N_ITEM = 4

If Item = RESTR_HORARIO then N_ITEM = 5.

I did the macro below, but it’s not working...

Public Sub Atualizar()
'
'faz outra tabela listando cada ganho individual
'facilita a manipulação de pivot's
Dim BD As Worksheet
Dim base As Worksheet
Dim b As Integer
Dim c As Integer
Dim itens As Range
Dim k As Long

Set BD = Sheets("Base_Distribuicao")
Set base = Sheets("base")
Application.ScreenUpdating = False
With base
.Range("A:M").ClearContents
.Range("a1").Value = "Cod_JDE"
   .Range("B1").Value = "CNPJ_8"
    .Range("C1").Value = "CNPJ"
    .Range("D1").Value = "CLIENTE"
    .Range("E1").Value = "REGIAO"
    .Range("F1").Value = "SUBREGIAO"
    .Range("G1").Value = "NEGOCIO"
    .Range("H1").Value = "PUBLICO_PRIVADO"
    .Range("I1").Value = "CDL_RESPONSAVEL"
    .Range("J1").Value = "PRODUTO"
    .Range("K1").Value = "ITEM"
    .Range("L1").Value = "N_ITEM"
    .Range("M1").Value = "FLAG"
End With
BD.Select
k = BD.Range("A1", BD.Range("A1").End(xlDown)).Rows.Count
For c = 1 To 7 'contagem de colunas dos itens, ajuda a generalizar o preenchimento por offset
If itens Is Nothing Then 'definindo a ptimeira coluna
Set itens = BD.Range("A1:AB5000").Find(what:="Nominal")
itens.Offset(1, 0).Select
Else
Set itens = itens.Offset(0, 1) 'definindo as colunas restantes
itens.Offset(1, 0).Select 'primeiro flag do item
End If
For b = 1 To k
If ActiveCell.Value <> "" And ActiveCell.Value <> "-" Then
base.Range("A2").EntireRow.Insert
Else
base.Range("A2") = ActiveCell.Offset(0, -(5 + c)).Value
base.Range("B2") = ActiveCell.Offset(0, 14 - c).Value
base.Range("C2") = ActiveCell.Offset(0, 15 - c).Value
base.Range("D2") = ActiveCell.Offset(0, 16 - c).Value
base.Range("E2") = ActiveCell.Offset(0, 17 - c).Value
base.Range("F2") = ActiveCell.Offset(0, 18 - c).Value
base.Range("G2") = ActiveCell.Offset(0, 19 - c).Value
base.Range("H2") = ActiveCell.Offset(0, 20 - c).Value
base.Range("I2") = ActiveCell.Offset(0, -(3 + c)).Value
base.Range("J2") = ActiveCell.Offset(0, -(2 + c)).Value
base.Range("M2") = ActiveCell.Value
base.Range("K2") = itens.Value

End If
ActiveCell.Offset(1, 0).Select ' proximo flag
Next
Next

Application.ScreenUpdating = True

End Sub

Answer 1

Good afternoon Thaís,

All right with you?

My suggested code has become giant, but I believe it will solve your problem.

First, note that the structure of the tabs I used to test are as follows::

• Tab "Base_distribution":

Tab "base":

Basically, what I did was copy the headers and values you wanted to turn into columns like transposed cells in the base tab.

And, to fill the other lines with the corresponding values, I made the code go through cell by cell of the tab "Base_distribution" and go pasting in the tab "base.

I strongly suggest that you read my code and test "debugging (that is, pressing the F8 key line by line)", because for the code to work well the commands need to correspond exactly to the structure of the spreadsheet.

At last, stay here:

Sub Transposicao()

Dim W       As Worksheet
Dim WB      As Worksheet
Dim A       As Integer
Dim B       As Integer
Dim C       As Integer
Dim L       As Integer
Dim UltCel  As Range

Application.ScreenUpdating = False

Set W = Sheets("Base_Distribuicao")
Set WB = Sheets("base")

WB.Select
WB.Range("A2:M1048576").Clear

W.Select
A = 2
B = 2
C = 2
'Set Col = W.Range("I1:O1")
Set UltCel = W.Range("A1048576").End(xlUp)

Do While A <= UltCel.Row

    'Copia as células da aba Base_Distribuicao a serem transpostas e cola na aba base, transpondo
    W.Select
    W.Range("I1:O1").Select
    Selection.Copy
    WB.Select
    WB.Range("J" & C).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    'Copia os valores correspondentes para a coluna FLAG
    W.Select
    W.Range("I" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("J" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("K" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("L" & C).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 3).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("M" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 4).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("N" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 5).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    W.Select
    W.Range("O" & A).Select
    Selection.Copy
    WB.Select
    WB.Range("K" & C + 6).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    'Copia os demais valores referentes ao respectivo IDE
    
    ''Copia o IDE
    B = WB.Range("A1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("C" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("A" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    ''Copia o CNPJ
    B = WB.Range("B1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("V" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("B" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    ''Copia o nome do cliente
    B = WB.Range("C1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("W" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("C" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia a região atual
    B = WB.Range("D1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("X" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("D" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia o subgrupo
    B = WB.Range("E1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("Y" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("E" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia o negócio
    B = WB.Range("F1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("Z" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("F" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia o públlico/privado
    B = WB.Range("G1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("AA" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("G" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia o CDL_Responsável
    B = WB.Range("H1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("E" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("H" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    'Copia o Installation Product
    B = WB.Range("I1048576").End(xlUp).Row + 1
    For L = 1 To 7
        W.Select
        W.Range("F" & A).Select
        Selection.Copy
        WB.Select
        WB.Range("I" & B).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        B = B + 1
    Next L
    
    A = A + 1
    C = C + 7
    
Loop

'Preenche a coluna N_ITEM
WB.Range("L2").Select

Set UltCel = WB.Range("K1048576").End(xlUp)

A = 2

Do While A <= UltCel.Row
    
    If WB.Range("J" & A).Value = "Standard" Then
    
        WB.Range("L" & A).Value = 1
    
    ElseIf WB.Range("J" & A).Value = "Nominal" Or WB.Range("J" & A).Value = "Umidade" Or WB.Range("J" & A).Value = "Grau_Bebida" Or _
        WB.Range("J" & A).Value = "Medicinal" Then
    
        WB.Range("L" & A).Value = 2
    
    ElseIf WB.Range("J" & A).Value = "Primeira_Entrega" Then
    
    
        WB.Range("L" & A).Value = 4
    
    ElseIf WB.Range("J" & A).Value = "Restr_Horario" Then
    
        WB.Range("L" & A).Value = 5
    
    End If


    A = A + 1
    

Loop



Application.ScreenUpdating = False

MsgBox "Pronto", vbOKOnly, "Status"

End Sub

If you have any problems, call me here.

I hope it helps.