行列入れ替えをTransposeを使用せずに行う方法

今回はあるブックから別ブックのシートへ貼り付けを行う際、行列を入れ替えて貼り付ける方法を考える。
Transposeメソッドはあえて使用せず、貼り付け元データを変数に格納してから行列入れ替えて貼り付けることにする。
実装するプログラムは1列→1行への入れ替えとする。

Sub CopyAndTransposeRowToColumn()
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim sourceFilePath As String
    Dim sourceRange As Range
    Dim dataArr As Variant
    Dim tempArr As Variant
    Dim maxColmns As Integer
    Dim i As Long
    
    ' コピー元のファイルパス
    sourceFilePath = "C:\Users\user\desktop\folder\sample.xlsx"
    
    ' 貼り付け先のワークシート
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    
    ' 画面更新オフ（処理を高速化）
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 非表示でブックを開く（読み取り専用）
    Set wb = Workbooks.Open(sourceFilePath, ReadOnly:=True)
    Set wsSource = wb.Sheets("Sheet1") ' コピー元のシートを指定
    
    ' コピー元の範囲（1列のデータ）
    Set sourceRange = wsSource.Range("A1:J1")
    
    '　データを配列に格納
    detaArr = sourceRange.Value
    
    ' データの列数をカウントする
    maxColmns = UBound(detaArr, 2)
    
    ' 転置用の仮の配列を作成
    ReDim tempArr(1 To maxColmns, 1 To 1)
    
    ' 転置処理（1列→1行
    For i = 1 To maxColmns
        tempArr(i, 1) = detaArr(1, i)
    Next i
    
    ' 転置したデータを貼り付け（1行maxColmns列にする）
    wsDest.Range("A1").Resize(maxColmns, 1).Value = tempArr
    
    ' ブックを閉じる
    wb.Close SaveChanges:=False
    
    ' オブジェクト開放
    Set sourceRange = Nothing
    Set wsSource = Nothing
    Set wb = Nothing
    
    ' 画面更新オン
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

コードの解説

1：変数を作成。

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim sourceFilePath As String
    Dim sourceRange As Range
    Dim dataArr As Variant
    Dim tempArr As Variant
    Dim maxColmns As Integer
    Dim i As Long

wb → コピー元のブック（Workbook）
wsSource → コピー元のシート（Worksheet）
wsDest → 貼り付け先のシート
sourceFile → コピー元のファイルパス
sourceRange → コピーする範囲
dataArr → コピー元のデータを格納する配列
tempArr → 転置（行列入れ替え）したデータを格納する配列
maxColmns → データの列数
i → ループ処理用の変数

2：コピー元のファイルパスを指定

sourceFilePath = "C:\Users\user\desktop\folder\sample.xlsx"

コピー元のExcelファイルのフルパスを指定

3：貼り付け先のワークシートを指定

Set wsDest = ThisWorkbook.Sheets("Sheet1")

ThisWorkbook → このマクロが実行されるExcelブック
"Sheet1" → 貼り付けるシート名を指定

4：画面更新をオフにして処理を高速化

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ScreenUpdating = False → 画面の更新を止めることで処理を高速化
DisplayAlerts = False → 警告メッセージを非表示（例：上書き確認ダイアログを出さない）

5：別のブックを開く

Set wb = Workbooks.Open(sourceFilePath, ReadOnly:=True)
Set wsSource = wb.Sheets("Sheet1")

Workbooks.Open(sourceFile, ReadOnly:=True) →
　　指定したExcelファイルを開く（読み取り専用）
Set wsSource = wb.Sheets("Sheet1") →
　　コピー元のシートを指定

6：コピーするデータの範囲を指定

Set sourceRange = wsSource.Range("A1:J1")

Range("A1:C10") → コピーするセル範囲を指定

7：セルの値を配列に格納

detaArr = sourceRange.Value

sourceRange.Value を dataArr に代入
これにより、コピー元のデータを配列 dataArr に一括で格納

8：データの列数を maxColmns に格納

maxColmns = UBound(detaArr, 2)

detaArrの列数を UBound()で計算し、maxColmnsに代入
UBound()の二つ目の引数を1にすると行数、2にすると列数が数えられる

9：転置用の配列を作成

ReDim tempArr(1 To maxColmns, 1 To 1)

ReDim tempArr(1 To 列数, 1 To 行数) →
　　転置後のサイズに合わせて tempArr を再定義（行と列を入れ替える）

10：転置処理（行列を入れ替える）

For i = 1 To maxColmns
    tempArr(i, 1) = detaArr(1, i)
Next i

i（列）のデータを i（行）に移動

11：転置したデータを貼り付け

wsDest.Range("A1").Resize(maxColmns, 1).Value = tempArr

Range("A1") から転置したデータを貼り付け
Resize(行数, 列数) で転置後のデータのサイズに合わせて貼り付け

12：コピー元のブックを閉じる

wb.Close SaveChanges:=False

SaveChanges:=False で保存せずにブックを閉じる

13：メモリ解放

Set sourceRange = Nothing
Set wsSource = Nothing
Set wb = Nothing

変数の参照を解除

14：画面更新を再開

Application.ScreenUpdating = True
Application.DisplayAlerts = True

このコードは1行のデータのみ対応できますが、複数行のデータにも対応するコードが必要であれば作成してみてください