Альтернативы или оптимизация Nested For Loop

Загрузите все в массив вариантов и зациклите его вместо диапазона. загрузите вывод в другой массив вариантов, а затем поместите эти данные как один обратно на лист.

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

Это немного долго, но довольно прямолинейно. Объяснение внутри комментариев кода.

Код

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

Если вас интересует более короткое решение... Предполагается, что ваши данные начинаются с ячейки 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