Sub test()
Dim i&, j%
On Error Resume Next
j = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To j
    If i = 1 Then
        Range(Cells(1, i), Cells(1, i).End(xlDown)).Copy _
            Cells(Cells(Rows.Count, j + 2).End(xlUp).Row, j + 2)
    Else: Range(Cells(1, i), Cells(1, i).End(xlDown)). _
            Copy Cells(Cells(Rows.Count, j + 2).End(xlUp).Row + 1, j + 2)
    End If
Next i
End Sub

Sub GlueArray()
Dim a, aRezult, i As Long, j As Long, k As Long, sh As Worksheet, rng As Range
Set rng = Sheets("Лист1").Cells(1, 1).CurrentRegion [B]'тут дает ошибку Run time error 9[/B]
a = rng.Value
ReDim aRezult(1 To UBound(a) * UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
  For i = 1 To UBound(a)
    If a(i, j) <> Empty Then
      k = k + 1
      aRezult(k, 1) = a(i, j)
    End If
  Next
Next
Set sh = Sheets.Add
sh.Name = Format(Now, "yymmdd_hhmmss")
sh.Cells(1).Resize(k) = aRezult
End Sub