How to paste a whole array without looping through it in VBA?

Question

I have this code which will populate an array

Sub rangearray()

    Dim arr() As Variant
    Dim Rng As Range
    Dim myCell As Range
    Dim i As Integer

    Set Rng = ActiveSheet.Range("G10:G14")

    For Each myCell In Rng
        ReDim Preserve arr(i)
        arr(i) = myCell
        i = i + 1
    Next myCell

    ActiveSheet.Range("H10:H14") = arr()

End Sub

Here you can see that the values in the watch window are what has been loaded in

Except, when I add the array back to the workbook it only pastes back the first element of the array.

Is it possible to paste the whole array to the worksheet without having to loop through the array?

After taking a look at the link from Sorceri, I have amended to code to use the .Transpose function, so my amended code now look like this:

Sub rangearray()

    Dim arr() As Variant
    Dim Rng As Range
    Dim myCell As Range
    Dim i As Integer

    Set Rng = ActiveSheet.Range("A1:A5")

    For Each myCell In Rng
        ReDim Preserve arr(i)
        arr(i) = myCell
        i = i + 1
    Next myCell

    ActiveSheet.Range("B1:B5") = WorksheetFunction.Transpose(arr)

End Sub

Answer 1

As I mentioned in my comment above that you do not need an array to perform the action that you trying to do but still if you want only an array solution then you don't need to go the long way of filling the array in a loop. Directly assign the range's value to the array. It will create a 2D array which you don't need to transpose.

Sub rangearray()
    Dim arr
    Dim Rng As Range

    With ActiveSheet
        Set Rng = ActiveSheet.Range("G10:G14")

        arr = Rng.Value

        .Range("H10").Resize(UBound(arr, 1)).Value = arr
    End With
End Sub

Answer 2

you will want to use the transpose worksheet function http://msdn.microsoft.com/en-us/library/office/ff196261.aspx

See below. You have to assign it to the range's value

Sub rangearray()

Dim arr() As Variant
Dim Rng As Range
Dim myCell As Range
Dim i As Integer

Set Rng = ActiveSheet.Range("A1:A5")

For Each myCell In Rng
    ReDim Preserve arr(i)
    arr(i) = myCell
    i = i + 1
Next myCell

ActiveSheet.Range("B1:B5").Value = WorksheetFunction.Transpose(arr)

End Sub