Excel のデータ整理マクロ（データを別シートに転記）をスピードアップしたい。

Question

前提・実現したいこと

excelに出力された時系列データがありますが、
データの並び順が特殊なため、整理するマクロを作成しました。
希望通りの動作にはなってはいますが、実行にとても時間がかかってしまうため
処理速度を上げたいです。
方法がわかりませんので、アイデアなどをいただけますと助かります。

<時系列データの構成>

右から左、上から下にデータが時系列で入力されている。

<出力イメージ>

別シートに縦１列で時系列順にデータを並べたい。

発生している問題・エラーメッセージ

実際は元データは 100列x1000行 程度の量があります。
この処理に数分～数十分かかってしまいます。

該当のソースコード

Sub Macro1()

Application.ScreenUpdating = False

Dim startrow As Integer 'データの最初の行
startrow = 5

Dim endrow As Integer 'データの最後の行
endrow = 1007

Dim firstrow As Integer 'データ整理シートの最初の行
firstrow = 3

Dim defrow As Integer '1行当たりのデータ数
defrow = 100

Dim lngrow As Long 'データ整理シートのデータ貼りつけセル変数
Dim dataarray() As Variant 'データ仮格納配列
Dim rdataarray() As Variant 'データを反転させた配列
Dim array1d As Variant '反転データから1行分を抽出した1次元配列

'配列の再定義
ReDim dataarray(1 To endrow, 1 To 100)
ReDim rdataarray(1 To endrow, 1 To 100)

Worksheets("元データ").Select
dataarray = Range(Cells(startrow, 5), Cells(endrow, 104))

'1行ごとに、データの向きを入れ替え
For i = 1 To endrow - startrow + 1
 For j = 1 To 100
    rdataarray(i, j) = dataarray(i, 100 - j + 1)
 Next j
Next i

'「データ整理」シートに貼り付け
For r = 5 To endrow
    lngrow = firstrow + defrow * (r - 5)
    
    Worksheets("元データ").Cells(r, 4).Copy Worksheets("データ整理").Cells(lngrow, 1)
    array1d = WorksheetFunction.Index(rdataarray, r - 4)
    
    Worksheets("データ整理").Select
    Range(Cells(lngrow, 2), Cells(lngrow + 99, 2)).Value = WorksheetFunction.Transpose(array1d)
Next r

Application.ScreenUpdating = True
End Sub

試したこと

おそらく、「データ整理シートに貼り付ける」ところが時間がかかっていると思われますが、
どう改善したらいいのかわかっていません。
よろしくお願いいたします。

補足情報（FW/ツールのバージョンなど）

Excel 2016

Answer 1

たとえばこんな感じでどうでしょうか。

Sub Sample()
    Dim rng As Range, arr As Variant
    Set rng = Worksheets("元データ").UsedRange
    arr = rng.Value
    
    Dim maxRow, maxCol
    maxRow = UBound(arr, 1)
    maxCol = UBound(arr, 2)
    
    Dim rng2 As Range, arr2 As Variant
    Set rng2 = Worksheets("データ整理").Range("A3").Resize(maxRow * (maxCol - 1), 2)
    arr2 = rng2.Value
    
    Dim i, j, r
    For i = 1 To maxRow
        arr2(r + 1, 1) = arr(i, 1)
        For j = maxCol To 2 Step -1
            r = r + 1
            arr2(r, 2) = arr(i, j)
        Next
    Next
    rng2.Value = arr2

End Sub

Comments

[Hiroms]

ご提案ありがとうございます！試して見ましたが、こちらも一瞬で完了させることができました。データ歯抜けなどがあったので少し微修正が必要ですが、考え方参考にさせていただきます！

Answer 2

大量のデータの転記処理の場合、なるべくRangeへのアクセスは減らすという方向で処理を考えるといいでしょう。

そこで、データ範囲のRangeを配列に格納。
出力のセル範囲と同じサイズの配列を用意しておいて、上記の配列から転記する。
出力用配列を出力のセル範囲に出力。
とすると、Rangeへのアクセスは2回ですみます。

コード例

Sub Macro1()
    Application.ScreenUpdating = False

    Dim startrow As Long    'データの最初の行
    startrow = 5
    Dim endrow As Long    'データの最後の行
    endrow = 1007
    Dim firstrow As Long    'データ整理シートの最初の行
    firstrow = 3
    
    Dim InRowCnt As Long  'データの行数
    InRowCnt = endrow - startrow + 1
    
    Dim defrow As Long    '1行当たりのデータ数
    defrow = 100

    Dim InAry() As Variant    '元データ格納配列
    With Worksheets("元データ")
        InAry = .Range(.Cells(startrow, 4), .Cells(endrow, 104)).Value
    End With

    Dim OutAry() As Variant   'データ整理格納配列
    ReDim OutAry(1 To InRowCnt * defrow, 1 To 2)


    Dim r As Long, c As Long, n As Long
    For r = 1 To InRowCnt
        OutAry(r * defrow - 99, 1) = InAry(r, 1)
        For c = defrow + 1 To 2 Step -1
            n = n + 1
            OutAry(n, 2) = InAry(r, c)
        Next
    Next

    Worksheets("データ整理").Cells(firstrow, 1).Resize(InRowCnt * defrow, 2).Value = OutAry


    Application.ScreenUpdating = True
End Sub

Comments

[Hiroms]

ありがとうございます。ご提案頂いたもので一瞬で完了できました。（一部の変数だけ微修正させていただきました。）

[Hiroms]

「なるべくRangeへのアクセスは減らすという方向」　勉強になりました。