Nested For Loop alternatives or optimization - excel

Question

Currently trying to append all cells in each row into the first cell of that row, and iterate through every row. Problem is I'm dealing with ~3000 rows with about 20 columns of data in each row. Is there any better way to append all cells in a row into one single cell without using a for loop? That could narrow down the code to a single for loop and may speed up the process.
Tried making a nested for loop that iterates through every row then every column per row. It works, but takes far too long when dealing with a large amount of data.
Sub AppendToSingleCell()
Dim value As String
Dim newString As String
Dim lastColumn As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To lastRow
lastColumn = Cells(j, Columns.Count).End(xlToLeft).Column
For i = 2 To lastColumn
If IsEmpty(Cells(j, i)) = False Then
value = Cells(j, i)
newString = Cells(j, 1).value & " " & value
Cells(j, 1).value = newString
Cells(j, i).Clear
End If
Next i
Next j
End Sub

Answer 1

Load everything into a variant array and loop that instead of the range. load the output into another variant array and then put that data as one back in the sheet.
Sub AppendToSingleCell()
With ActiveSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
Dim lastColumn As Long
lastColumn = .Cells.Find(What:="*", After:=.Range("a1"), LookIn:=xlValue, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim dtaArr() As Variant
dtaArr = .Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).value
Dim otArr() As Variant
ReDim otArr(1 To lastRow, 1 To 1)
Dim i As Long
For i = LBound(dtaArr, 1) To UBound(dtaArr, 1)
For j = LBound(dtaArr, 2) To UBound(dtaArr, 2)
If dtaArr(i, j) <> "" Then otArr(i, 1) = otArr(i, 1) & dtaArr(i, j) & " "
Next j
otArr(i, 1) = Application.Trim(otArr(i, 1))
Next i
.Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).Clear
.Range(.Cells(1, 1), .Cells(lastRow, 1)).value = otArr
End With
End Sub

Answer 2

It's a bit long, but pretty straight forward.
Explanation inside the code's comments.
Code
Option Explicit
Sub AppendToSingleCell()
Dim newString As String
Dim LastRow As Long, LastColumn As Long
Dim Sht As Worksheet
Dim FullArr As Variant, MergeCellsArr As Variant
Dim i As Long, j As Long
Set Sht = ThisWorkbook.Sheets("Sheet1") ' <-- rename "Sheet1" to your sheet's name
With Sht
LastRow = FindLastRow(Sht) ' call sub that finds last row
LastColumn = FindLastCol(Sht) ' call sub that finds last column
' populate array with enitre range contents
FullArr = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
ReDim MergeCellsArr(1 To LastRow) ' redim 1-D array for results (same number of rows as in the 2-D array)
' looping through array is way faster than interfacing with your worksheet
For i = 1 To UBound(FullArr, 1) ' loop rows (1st dimension of 2-D array)
newString = FullArr(i, 1)
For j = 2 To UBound(FullArr, 2) ' loop columns (2nd dimension of 2-D array)
If IsEmpty(FullArr(i, j)) = False Then
newString = newString & " " & FullArr(i, j)
End If
Next j
MergeCellsArr(i) = newString ' read new appended string to new 1-D array
Next i
' paste entire array to first column
.Range("A1").Resize(UBound(MergeCellsArr)).value = MergeCellsArr
End With
End Sub
'=======================================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
Exit Function
End If
End With
End Function
'=======================================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.Row
Else
MsgBox "Error! worksheet is empty", vbCritical
Exit Function
End If
End With
End Function

Answer 3

If you're interested in a shorter solution.... It assumes your data begins in cell A1.
Public Sub CombineColumnData()
Dim arr As Variant
Dim newArr() As Variant
Dim varTemp As Variant
Dim i As Long
arr = ActiveSheet.Range("A1").CurrentRegion.Value
ReDim newArr(1 To UBound(arr, 1))
For i = LBound(arr, 1) To UBound(arr, 1)
varTemp = Application.Index(arr, i, 0)
newArr(i) = Join(varTemp, "")
Next i
With ActiveSheet.Range("A1")
.CurrentRegion.Clear
.Resize(UBound(arr, 1), 1) = Application.Transpose(newArr)
End With
End Sub