```
Sub combineCols()
Dim r As Range
Dim a(), b()
Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Set r = Range("A6", .Cells(lastRow, "WZ"))
totalValues = Application.CountA(r)
If totalValues > Rows.Count Then
MsgBox "Can't be done. Not enough rows!!!", vbCritical
Else
k = 0
ReDim b(1 To totalValues, 1 To 1)
For j = 1 To UBound(a, 2)
For i = 1 To UBound(a)
If LenB(a(i, j)) Then
k = k + 1
b(k, 1) = a(i, j)
End If
Next j
Next j
Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
Erase a
Erase b
End If
Set r = Nothing
End Sub
```