VBA Combine columns stack in the loop - vba

Question

I have the issue with stacking in the loop
The macro should combine all columns (changeable number of rows) into one column.
Sub CombineColumns()
Dim xRng As Range
Dim i As Integer
Dim xLastRow As Integer
On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlDown).End(xlToRight))
xLastRow = xRng.Columns(1).Rows.Count + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(xRng.Columns(i).Rows.Count, i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = xLastRow + xRng.Columns(i).Rows.Count
Next
End Sub

Answer 1

Using Array is simple and fast.
Sub test()
Dim Ws As Worksheet, toWS As Worksheet
Dim vDB, vR()
Dim i As Long, j As Integer, n As Long
Set Ws = ActiveSheet
vDB = Ws.UsedRange
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 1 To r
For j = 1 To c
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, j)
Next j
Next i
Set toWS = Sheets.Add ' set toWs = Sheets(2) ~~> set your sheet
With toWS
.Cells.Clear
.Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End With
End Sub

Answer 2

If I got you right you want to do sth. like that
Option Explicit
Sub CombineColumns()
Dim xRng As Range
Dim i As Long
Dim xLastRow As Long
'On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlToRight))
xLastRow = lastRow(1) + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(lastRow(i), i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = lastRow(1) + 1
Next
End Sub
Function lastRow(col As Long, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
The code still needs some improvement as it might loop over all columns espeically if there is no data.

Answer 3

This assumes on all your columns you have data on the 2nd row, to correctly identify the last column.
Option Explicit
Public Sub CombineColumns()
Dim LastColumn As Long, LastRow As Long, LastRowA As Long, i As Long, RngAddress As String
With ActiveSheet
' This assumes you have data on row 2 on all columns
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastColumn
' Get the last row of Col A on each iteration
LastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
' Get last row of the Col we're checking
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Get the used range address of the current Col
RngAddress = .Range(.Cells(1, i), Cells(LastRow, i)).Address
' Check if we have blank cells among the rows of the current Col
.Range(.Cells(1, i), Cells(LastRow, i)).Value2 = Evaluate("IF(NOT(ISBLANK(" & RngAddress & "))," & RngAddress & ")")
' Compress data (if there's no empty cells in the current Col the below line will give error, that's the role of err handling)
On Error Resume Next
.Range(.Cells(1, i), Cells(LastRow, i)).SpecialCells(xlCellTypeConstants, 4).Delete xlShiftUp
On Error GoTo 0
' Update the last row in case we compressed data
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Paste data in Col A
.Range(.Cells(1, i), Cells(LastRow, i)).Cut Destination:=.Range("A" & LastRowA)
Next i
Application.CutCopyMode = False
End With
End Sub

Answer 4

Maybe this could be a convenient solution for you :
Sub CombineColumns()
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Range("A2:A" & LastRow).Formula = "=B2 & C2 & D2 & E2 & F2 & G2 & H2" 'Insert here the columns you need to be combined
End Sub
Let me know if changes are necessary.