【EXCEL VBA（マクロ）】別シートの縦持ちデータを表形式して貼り付ける

別シートの縦持ちデータを表形式に転記

このコードは、Excel VBAを使用して、1つのシートの縦持ちデータを別のシートに表形式で転記するためのコードです。以下は、コードの詳細な説明です。

＊別シートにある縦持ちのデータを表形式に変換して転記

Sub 別シートの縦持ちデータを表形式に転記()

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
    
'処理(マッチング)
ws2.Range("A2:A" & LastRow1).Value = ws1.Range("A2:A" & LastRow1).Value

For i = 2 To LastRow1

  On Error Resume Next
  
  If ws1.Cells(i, 1).Value = ws2.Cells(i, 1).Value Then
     ws2.Cells(i, 1).Offset(0, 1).Value = ws1.Cells(i, 1).Offset(0, 1).Value
     ws2.Cells(i, 1).Offset(0, 2).Value = ws1.Cells(i, 1).Offset(0, 2).Value
    End If

Next i

MsgBox "完了_" & Err.Number
End Sub

解説

最初に、Excelのアプリケーション設定を変更して、スクリーン更新、イベント処理、アラート表示、計算を無効にします。

次に、基本的なアクティブなワークシートと相手のワークシートを選択し、それぞれの最後の行と最後の列を決定します。

そして、処理を行います。基本的なワークシートのA列と相手のワークシートのA列を一致させ、次の列に基本的なワークシートの2列目と3列目のデータをコピーします。

ループ内でエラーハンドリングを使用していることにも注意してください。これは、ワークシートが一致しない場合にエラーナンバーを返すためです。

最後に、完了メッセージボックスを表示します。

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

このコードは、最初に元のデータ範囲を配列に格納し、配列を操作して処理を行います。特に、以下の点が改善されています。

Sub 別シートの縦持ちデータを表形式に転記()

    'アプリケーションの設定
    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 arr1 As Variant
    arr1 = ws1.Range("A2:C" & LastRow1).Value 'データの範囲を配列に格納
    
    Dim arr2 As Variant
    arr2 = ws2.Range("A2:C" & LastRow1).Value 'データの範囲を配列に格納
    
    Dim i As Long
    Dim j As Long
    For i = 1 To UBound(arr1) 'データ数だけループ
        For j = 1 To 3 'カラム数だけループ
            If arr1(i, 1) = arr2(i, 1) Then
                arr2(i, j) = arr1(i, j)
            End If
        Next j
    Next i
    
    ws2.Range("A2:C" & LastRow1).Value = arr2 '配列のデータをシートに転記
    
    'アプリケーションの設定
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "完了"

End Sub