How to transform a table into 3 columns in Excel

Question

I'm working with an extract file in Excel. It's basically multiple columns with several row data on each.

 A   | B   | C    | D   | E   | F    |
 1   | 2   | 3    | 1   | 2   | 3    |
 4   | 5   | 5    | 4   | 5   | 5    |

I would like to flatten it into 3 columns, like this :

 A   | B   | C    |
 1   | 2   | 3    |
 4   | 5   | 5    |
 D   | E   | F    |
 1   | 2   | 3    |
 4   | 5   | 5    |

I'd like to do it using VBA but I'm really new to this language, here is what I've done so far :

Sub test()
    Dim Key, Dic As Object, cl As Range, Data As Range, i&, n&
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    i = Cells(Rows.Count, "A").End(xlUp).Row
    n = 1
    Set Data = Range("B2:B" & i & "," & "D2:D" & i & "," & "F2:F" & i & "," & "H2:H" & i)
    Dic.Add "|ID", "Date|Thing"
    For Each cl In Data
        If Cells(cl.Row, "A") <> "" Then
            Dic.Add n & "|" & Cells(cl.Row, "A"), cl.Text & "|" & cl.Offset(, 1).Text
            n = n + 1
        End If
    Next cl
    n = 1
    For Each Key In Dic
        Cells(n, "K") = Split(Key, "|")(1)
        Cells(n, "L") = Split(Dic(Key), "|")(0)
        Cells(n, "M") = Split(Dic(Key), "|")(1)
        n = n + 1
    Next Key
End Sub

It gives me this result :

 A   | A   | A    |
 B   | B   | B    |
 C   | C   | C    |
 1   | 1   | 1    |
 2   | 2   | 2    |
 3   | 3   | 3    |
 4   | 4   | 4    |
 5   | 5   | 5    |
 6   | 6   | 6    |
 D   | D   | D    |
 E   | E   | E    |
 F   | F   | F    |
 1   | 1   | 1    |
 2   | 2   | 2    |
 3   | 3   | 3    |
 4   | 4   | 4    |
 5   | 5   | 5    |
 6   | 6   | 6    |

Could you help me please ?

Answer 1

Unless I'm missing something, you're over-complicating this.

If you have this:

...then use this:

Range("D1:F3").Cut Range("A4")

...to get this:

Here's more info about the Range.Cut method.

Handy for learning how to automate basic tasks, see "Recording a Macro to Generate Code". Also good info in "Getting started with VBA in Office".

Answer 2

This code will turn

into

You just need to define the amount of columns you want: Const AmountOfColumns As Long = 3

Option Explicit

Public Sub LimitColumns()
    Const AmountOfColumns As Long = 3  ' define how many columns you want in the end
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    Dim LastRow As Long  ' amount of initial rows
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim LastCol As Long  ' amount of initial columns
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Dim AmountOfSteps As Long  ' amount of blocks we need to copy
    AmountOfSteps = LastCol \ AmountOfColumns
    
    Dim LastStep As Long  ' if the last block is smaller
    LastStep = LastCol Mod AmountOfColumns
    
    ' move all blocks
    Dim s As Long
    For s = AmountOfColumns + 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
        ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Cut ws.Cells(((s - 1) / AmountOfColumns) * LastRow + 1, 1)
    Next s
    
    ' move last block  (if it has less columns than the others)
    If LastStep > 0 Then
        ws.Cells(1, AmountOfSteps * AmountOfColumns + 1).Resize(LastRow, LastStep).Cut ws.Cells(AmountOfSteps * LastRow + 1, 1)
    End If
End Sub

This uses cut and paste, if you prefer only to move the values (without formattings) you can change to this:

    ' move all blocks
    Dim s As Long
    For s = AmountOfColumns + 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
        ws.Cells(((s - 1) / AmountOfColumns) * LastRow + 1, 1).Resize(LastRow, AmountOfColumns).Value2 = ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Value2
    Next s
    
    ' move last block  (if it has less columns than the others)
    If LastStep > 0 Then
        ws.Cells(AmountOfSteps * LastRow + 1, 1).Resize(LastRow, LastStep).Value2 = ws.Cells(1, AmountOfSteps * AmountOfColumns + 1).Resize(LastRow, LastStep).Value2
    End If
            
    ' clear old values
    ws.Cells(1, AmountOfColumns + 1).Resize(LastRow, LastCol - AmountOfColumns).ClearContents

which might be even faster.

Answer 3

Get Stacked Columns

• If you're not OP, to test it, you can open a new workbook and make sure you have the Sheet1 and Sheet2 tabs. Copy the code to a standard module, e.g. Module1. Add some contiguous data (no empty rows or columns) starting in cell A1 of Sheet1 and run the first procedure. See the results in Sheet2. Play with the constants ColumnsCount and Gap to see how they change the result.

Option Explicit

Sub GetStackedColumnsTEST()
         
     Const sName As String = "Sheet1"
     Const sFirstCellAddress As String = "A1"
     Const ColumnsCount As Long = 3
     Const Gap As Long = 0
     
     Const dName As String = "Sheet2"
     Const dFirstCellAddress As String = "A1"
         
     Dim wb As Workbook: Set wb = ThisWorkbook
     
     Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
     Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
     
     Dim Data As Variant: Data = GetStackedColumns(srg, ColumnsCount, Gap)
     Dim rc As Long: rc = UBound(Data, 1)
     
     Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
     With dws.Range(dFirstCellAddress).Resize(, ColumnsCount)
         .Resize(rc) = Data
         .Resize(dws.Rows.Count - .Row - rc + 1).Offset(rc).ClearContents
     End With
    
End Sub

Function GetStackedColumns( _
    ByVal SourceRange As Range, _
    ByVal ColumnsCount As Long, _
    Optional ByVal Gap As Long = 0) _
As Variant
    Const ProcName As String = "GetStackedColumns"
    On Error GoTo ClearError
    
    Dim rCount As Long: rCount = SourceRange.Rows.Count
    Dim cCount As Long: cCount = SourceRange.Columns.Count
    
    Dim sData As Variant: sData = SourceRange.Value
    
    Dim StacksCount As Long: StacksCount = Int(cCount / ColumnsCount)
    Dim ColumnCrumbs As Long: ColumnCrumbs = cCount Mod ColumnsCount
    If ColumnCrumbs > 0 Then StacksCount = StacksCount + 1
    
    Dim drCount As Long
    drCount = StacksCount * rCount + (Gap * (StacksCount - 1))
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
    
    Dim st As Long, sr As Long, sc As Long, dr As Long, dc As Long
    
    For st = 1 To StacksCount - 1
        sc = (st - 1) * ColumnsCount
        For sr = 1 To rCount
            dr = dr + 1
            For dc = 1 To ColumnsCount
                dData(dr, dc) = sData(sr, sc + dc)
            Next dc
        Next sr
        dr = dr + Gap
    Next st
    
    If ColumnCrumbs = 0 Then ColumnCrumbs = ColumnsCount
    sc = (st - 1) * ColumnsCount
    For sr = 1 To rCount
        dr = dr + 1
        For dc = 1 To ColumnCrumbs
            dData(dr, dc) = sData(sr, sc + dc)
        Next dc
    Next sr
    
    GetStackedColumns = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

Answer 4

So if I understood this right you want to change something like this:

to something like this:

you could achieve this with the following code. Keep in mind last time I actively programmed is some years ago so this is not optimized.

Sub adjustList()
    Dim columWhereToSplit As Integer
    Dim lastColumn As Integer
    Dim columnsFormatted As Integer
    columWhereToSplit = 7
    lastColumn = 12
    columnsFormatted = 0
    
    NumRows = Cells(Rows.Count, columWhereToSplit).End(xlUp).Row
    
    For counter = columWhereToSplit To lastColumn
        Cells(1, counter).Select
        For counter_2 = 1 To NumRows
            Cells(counter_2, counter).Select
            Cells(NumRows + counter_2, 1 + columnsFormatted) = ActiveCell
            ActiveCell = ""
        Next
        columnsFormatted = columnsFormatted + 1
    Next
End Sub

Answer 5

This can also be accomplished using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)

To use Power Query

• Select some cell in your Data Table
• Data => Get&Transform => from Table/Range or from within sheet
• When the PQ Editor opens: Home => Advanced Editor
• Make note of the Table Name in Line 2
• Paste the M Code below in place of what you see
• Change the Table name in line 2 back to what was generated originally.
• Read the comments and explore the Applied Steps to understand the algorithm

M Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table31"]}[Content],

//demote headers since they will be part of the column content
   #"Demoted Headers" = Table.DemoteHeaders(Source),
    colNames = Table.ColumnNames(#"Demoted Headers"),

//split the list of column names into groups of three
    triplets = List.Split(colNames,3),

//split into three column tables
    cols3Tables = List.Accumulate(triplets,{},(state,current)=>
        state & {Table.SelectColumns(#"Demoted Headers",current)}),

//Change column headers to be the same for each table
    renameHeaders = List.Transform(cols3Tables, each Table.RenameColumns(_,    
        List.Zip({Table.ColumnNames(_),Table.ColumnNames(cols3Tables{0})}))),

//convert list to table
// then expand it
    #"Converted to Table" = Table.FromList(renameHeaders, Splitter.SplitByNothing(), null, null, ExtraValues.Error),
    #"Expanded Column1" = Table.ExpandTableColumn(#"Converted to Table", "Column1", 
        {"Column1", "Column2", "Column3"}, {"Column1", "Column2", "Column3"})

in
    #"Expanded Column1"