web-dev-qa-db-ja.com

VBAでループせずに配列全体を貼り付ける方法は?

私はこのコードを持っています

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

ここでは、ウォッチウィンドウの値がロードされたものであることがわかります。

enter image description here

例外として、配列をワークブックに追加して戻すと、配列の最初の要素のみが貼り付けられます。

enter image description here

配列をループすることなく、配列全体をワークシートに貼り付けることはできますか?

Sorceriからのリンクを見て、.Transpose関数を使用するようにコードを修正したため、修正後のコードは次のようになります。

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
10
spences10

転置ワークシート関数を使用します http://msdn.Microsoft.com/en-us/library/office/ff196261.aspx

下記参照。範囲の値に割り当てる必要があります

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
12
Sorceri

上記のコメントで述べたように、実行しようとしているアクションを実行するために配列は必要ありませんが、配列ソリューションのみが必要な場合は、配列をループで埋める長い道のりを行く必要はありません。範囲の値を配列に直接割り当てます。転置する必要のない2D配列が作成されます。

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
8
Siddharth Rout

ちょうどRng arrに割り当ててからシートに戻す。Excel2016で機能する

Sub rangearray()

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

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

    arr = Rng

    ActiveSheet.Range("B1:B5").Resize(5) = arr

End Sub
0
Dinesh Madhup