Stack Multiple columns into one columns in excel vba

Question

I have multiple columns (15 to 16) of data ( see Image ).

It has One number that is split into 3 columns Eg. 147 is split into three columns 1, 4, 7 and 268 is split into 2,6,8. Now i want to stack the data in a way as presented in this image

For this I tried to concatenate the three columns to make a single digit such as 1,4,7 are combined to form 147 and 2,6,8 are combined to form 268. The code i have written has given output 148 and 268 but it has two empty columns in between them shown as this .

I am not able to stack these columns to get desired output. Please suggest any method to stack from input to desired output directly Or any amendment in my current code so that i get the concatenated data in sequential columns.

Note:- The number of rows and columns are variable not static.

Sub JoinAndCut()
Dim n As Long
Dim p, col As Long
Dim lastrow As Long
For p = 1 To 25 Step 3

lastrow = ThisWorkbook.Worksheets(2).Cells(Rows.count, p).End(xlUp).Row   '<== To Count number of rows in each column

For n = 2 To lastrow

Cells(n, p).Offset(, 25).Value = Cells(n, p).Value & Cells(n, p + 1).Value & Cells(n, p + 2).Value ' <=== Offset by 25 values so as they dont overlap the input

Next n
Next p

End Sub


Sub JoinAndCut()
Dim n As Long
Dim p, col As Long
Dim lastrow As Long
For p = 1 To 25 Step 3

lastrow = ThisWorkbook.Worksheets(2).Cells(Rows.count, p).End(xlUp).Row   '<== To Count number of rows in each column

For n = 2 To lastrow

Cells(n, p).Offset(, 25).Value = Cells(n, p).Value & Cells(n, p + 1).Value & Cells(n, p + 2).Value ' <=== Offset by 25 values so as they dont overlap the input

Next n
Next p

End Sub

Answer 1

You could try this:

Sub JoinAndCut()
    Dim n As Long
    Dim p, col As Long
    Dim lastrow As Long, lastrowstack As Long
    For p = 1 To 25 Step 3

        lastrow = ThisWorkbook.Worksheets(2).Cells(Rows.Count, p).End(xlUp).Row   '<== To get row number in each column
        lastrowstack = ThisWorkbook.Worksheets(2).Cells(Rows.Count, 26).End(xlUp).Row   '<== To get row number in in the stacked column

        For n = 2 To lastrow
            
            Cells(n + lastrowstack - 1, 26).Value = Cells(n, p).Value & Cells(n, p + 1).Value & Cells(n, p + 2).Value ' <=== Starting in column 26 so as they dont overlap the input

        Next n
    Next p

End Sub

Let's say you had something like this:

Data in html format

You would then have them combined and stacked in column Z (aka. column 26) and the first 36 rows would look like this .

Answer 2

If I understand what you want correctly, which is a three column table with a single value in each column, the following should help.

I chose to use Power Query (available in Excel 2010+)

Algorithm:

• Unpivot all the columns:
  • Results in 2 columns consisting of the column header and value
• Add an index column and then add an Integer/Divide column where we divide the Index column by 3.
  • This returns a column of 0,0,0,1,1,1,2,2,2, ...
• Group by the Integer/Divide column
• Extract the values from the resultant table into a delimiter separated list.
• Split the list into columns.
• Delete the unneeded columns and we're done.
• If you add or remove columns/rows and Refresh , the output table will reflect that.

I suggest you

• Select a cell in your data.table
• Enter Power Query
  • In Excel 2016+, Data-->Get&Transform-->From Table/Range
    • In other versions, you install a free add-in from MS and follow those directions
• In the PQ UI, go to Home/Advanced Editor
  • Note the Table name in Line 2
  • Delete the contents of the editor, and paste the M Code below into its place
    • Change the Table name in line 2 to match your real table name.
  • Examine the Applied Steps window to see better what is done at each step.
    • double click the steps with a settings gear icon to show the options

M Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {}, "Attribute", "Value"),
    #"Added Index1" = Table.AddIndexColumn(#"Unpivoted Other Columns", "Index", 0, 1),
    #"Inserted Integer-Division" = Table.AddColumn(#"Added Index1", "Integer-Division", each Number.IntegerDivide([Index], 3), Int64.Type),
    #"Removed Columns1" = Table.RemoveColumns(#"Inserted Integer-Division",{"Index", "Attribute"}),
    #"Grouped Rows" = Table.Group(#"Removed Columns1", {"Integer-Division"}, {{"Grouped", each _, type table [Value=number, #"Integer-Division"=number]}}),
    #"Removed Columns" = Table.RemoveColumns(#"Grouped Rows",{"Integer-Division"}),
    #"Added Custom" = Table.AddColumn(#"Removed Columns", "Column", each Table.Column([Grouped],"Value")),
    #"Extracted Values" = Table.TransformColumns(#"Added Custom", {"Column", each Text.Combine(List.Transform(_, Text.From), ";"), type text}),
    #"Split Column by Delimiter" = Table.SplitColumn(#"Extracted Values", "Column", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), {"Column.1", "Column.2", "Column.3"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Split Column by Delimiter",{{"Column.1", Int64.Type}, {"Column.2", Int64.Type}, {"Column.3", Int64.Type}}),
    #"Removed Columns2" = Table.RemoveColumns(#"Changed Type",{"Grouped"})
in
    #"Removed Columns2"

Original Data

Results

If doing it in VBA is an absolute requirement, you can try this code: but read through it so you can change the range and worksheet references appropriately:

Option Explicit
Sub JoinAndCut()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range, col As Collection, vSrc, vRes
    Const firstRow As Long = 31
    Const firstCol As Long = 1
    Dim I As Long, J As Long, K As Long, arr(0 To 2), v
    
'read the data into VBA array
Set wsSrc = ThisWorkbook.Worksheets("sheet9")
With wsSrc
    vSrc = .Cells(firstRow, firstCol).CurrentRegion
End With

'collect output array
Set col = New Collection
For I = 2 To UBound(vSrc, 1) 'skip the header row
    For J = 1 To UBound(vSrc, 2) Step 3
        For K = 0 To 2
            arr(K) = vSrc(I, J + K)
        Next K
        If arr(0) <> "" Then col.Add arr 'skip the blanks
    Next J
Next I

'Create results array
ReDim vRes(0 To col.Count, 1 To 3)

'Headers
vRes(0, 1) = "Column.1"
vRes(0, 2) = "Column.2"
vRes(0, 3) = "Column.3"

'Populate
I = 0
For Each v In col
    I = I + 1
    For J = 1 To 3
        vRes(I, J) = v(J - 1)
    Next J
Next v

'Set output range
Set wsRes = wsSrc
    Set rRes = wsRes.Cells(50, 1)
    Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
    
    With rRes
        .ClearContents
        .Value = vRes
      'could add formatting commands
    End With
End Sub

Either one of the above can be easily modified to output the results as triplets, instead of in three separate columns, should I have misunderstood you.