[Excel VBA]大量のセルの値を一括で読み込み

Excel

複数セルに値を一発で書き込みのエントリの逆で、今度は大量のセルの値を一括で読み込みをしてみる。

こっちもVariant型の二次元配列を使います。

入力

100列1000行のシートにRANDBETWEEN関数でランダムな値を入れ、値貼り付け。
シート名は「in」

出力

各セルの値の行番号、列番号、値を出力する。1行目はタイトル行で明細は2行目から。
シート名は「out」。

コード

ポイントは、以下の通り
1. 出力用の二次元配列(Variant型。↓のコードでは変数vout)を作る
2. 出力用の二次元配列に値をセット(一次元目が行方向、二次元目が列方向)
3. 出力用の二次元配列と行数、列数が同じRangeオブジェクト(↓のコードでは変数rout)を作る。
4. 出力用の二次元配列をRangeのValueプロパティにセット。

Excelのオブジェクトへのアクセスが少なくなるので高速です。1秒かかりません。

Option Explicit
Public Sub Flatten3()
    Dim a As Excel.Application
    Dim b As Workbook
    Dim w As Worksheet
    Dim rr As Range
    Dim v As Variant
    Dim i As Long
    Dim j As Long

    Dim wout As Worksheet
    Dim rout As Range

    Dim row As Long
    Dim column As Long
    Dim value As String

    Dim vout As Variant
    Dim rowCount As Long
    Dim k As Long

    Debug.Print Time & " - Flatten3 スタート"

    ''Workbook変数セット
    Set a = Application
    Set b = a.ThisWorkbook

    ''inシートの範囲指定
    Set w = b.Worksheets("in")
    Set rr = w.Range("A1")
    Set rr = w.Range(rr, rr.End(xlToRight).End(xlDown))

    ''outシートのクリア
    Set wout = b.Worksheets("out")
    wout.Range("2:1000000").ClearContents

    ''outシートの初期位置をA1に。
    Set rout = wout.Range("A1")

    ''100列1000行の値を一括してVariantに入れる→2次元配列になる。
    Debug.Print Time & " - Flatten3 読み込み"
    v = rr.value

    Debug.Print Time & " - Flatten3 ループ＋書き込み用配列作成"

    ''出力用の配列を定義。行数100*1000、列数3
    rowCount = UBound(v, 1) * UBound(v, 2)
    ReDim vout(1 To rowCount, 1 To 3)

    ''列方向のループ
    For i = LBound(v, 1) To UBound(v, 1)
        ''行方向のループ
        For j = LBound(v, 2) To UBound(v, 2)
            row = i
            column = j
            value = v(i, j)        

            ''出力用配列にセット
            k = k + 1
            vout(k, 1) = row
            vout(k, 2) = column
            vout(k, 3) = value
        Next j
    Next i

    Debug.Print Time & " - Flatten3 配列から書き込み"
    ''A2を起点として、出力用配列と同サイズのRangeをセット
    Set rout = wout.Range("A2").Resize(rowCount, 3)

    ''配列から一括書き込み
    rout.value = vout

    Debug.Print Time & " - Flatten3 終了"
    MsgBox "終了!"
End Sub