How to transform a table into 3 columns in Excel-CodePudding

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 ?

CodePudding user response：

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

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.

CodePudding user response：

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