【EXCEL VBA（マクロ）】縦（行）ループして、複数列を1列にして別シート転記する

複数列を1列にして別シート転記する

このコードは、複数の列を1列にまとめて、別のシートに転記するマクロです。

Sub 複数列を1列にして別シート転記()

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With

'基_アクティブシート
Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
    Set ws1 = wb1.ActiveSheet
Dim LastRow1 As Long
    LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol1 As Long
    LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

'相手_アクティブシートの右のシート
Dim wb2 As Workbook
    Set wb2 = ThisWorkbook
Dim ws2 As Worksheet
    Set ws2 = wb2.ActiveSheet.Next
Dim LastRow2 As Long
    LastRow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
Dim LastCol2 As Long
    LastCol2 = ws2.Cells(2, Columns.Count).End(xlToLeft).Column
    
 Dim Start_Row As Long

    '転記開始行
    Start_Row = 2

    '4列分ループ
    For i = 1 To LastCol1

        'コピーして貼り付け
        ws1.Range(Cells(2, i), Cells(Last_Row1, i)).Copy ws2.Cells(Start_Row, 1)

        '転記開始行
        Start_Row = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1

    Next i
    
'キーアイテム削除
Set myDic = Nothing
Set wb2 = Nothing
Set ws2 = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With

MsgBox "完了"
End Sub

このVBAコードは、複数列のデータを1列に結合して、別のシートに転記するものです。

最初の部分は、スクリーン更新、イベント、アラート、計算を無効にする設定を行っています。これは、コードの実行時間を短縮し、エラーが発生しないようにするためのものです。

次に、現在アクティブなシートからデータを取得しています。これらは、転記元と転記先のシートとして使用されます。

ループの開始前に、転記先シートの開始行を設定しています。その後、ループを使用して、転記元シートの列を1つずつ処理し、各列のデータを転記先シートにコピーして貼り付けます。このループは、転記元シートの列の数だけ繰り返されます。

最後に、設定を元に戻し、完了メッセージを表示します。

改善点としては、以下のようなものがあります。

コピーして貼り付ける代わりに、データを配列に読み込んでから、配列を転記先シートに書き込むことで処理速度を高速化できます。

オブジェクトを使用して、開発者が使用した後にメモリを解放することで、リソースをより効率的に使用できます。最後の部分でオブジェクトを解放することができます。

上記コードのスピードアップ改善コード

Sub 複数列を1列にして別シート転記２()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

'基_アクティブシート
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
Set ws1 = wb1.ActiveSheet
Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol1 As Long
LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

'相手_アクティブシートの右のシート
Dim wb2 As Workbook
Set wb2 = ThisWorkbook
Dim ws2 As Worksheet
Set ws2 = wb2.ActiveSheet.Next
Dim LastRow2 As Long
LastRow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
Dim LastCol2 As Long
LastCol2 = ws2.Cells(2, Columns.Count).End(xlToLeft).Column

Dim Start_Row As Long

'転記開始行
Start_Row = 2

'4列分ループ
For i = 1 To LastCol1
    
    '最終行を取得
    Dim Last_Row1 As Long
    Last_Row1 = ws1.Cells(Rows.Count, i).End(xlUp).Row
    
    'データを配列に読み込む
    Dim Data() As Variant
    Data = ws1.Range(Cells(2, i), Cells(Last_Row1, i)).Value
    
    '配列を転記先シートに書き込む
    ws2.Cells(Start_Row, 1).Resize(UBound(Data), 1).Value = Data
    
    '転記開始行
    Start_Row = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1

Next i

'オブジェクトを解放
Set wb1 = Nothing
Set ws1 = Nothing
Set wb2 = Nothing
Set ws2 = Nothing

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With

MsgBox "完了"
End Sub

このコードでは、配列を使用してデータを転記先シートに書き込んでいるため、処理速度が高速化されます。また、オブジェクトを解放しているため、リソースをより効率的に使用できます。