シート跨ぎ転記(2シート間転記)マクロ

1 転記元シートから転記先シートへの転記

2 コード

 
Option Explicit


'転記先シートのシートモジュールに記載
'シート跨ぎ転記
Private Sub Worksheet_Activate()
    '転記元シート
    Dim wsFrom As Worksheet: Set wsFrom = Sheets("sheet1")
    With wsFrom
        Dim lastRow As Long
        lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
    End With
    
    'sheet2のシートモジュールに書くので、wsToは省略できる
    Dim wsTo As Worksheet: Set wsTo = Sheets("sheet2")
    With wsTo
        '初期化
        .Rows("11:" & .Rows.Count).ClearContents
        '日付入力
        .Range("F2").Value = Date
        '転記
        .Range("A11:A" & lastRow).Value = wsFrom.Range("A11:A" & lastRow).Value
        .Range("B11:B" & lastRow).Value = wsFrom.Range("B11:B" & lastRow).Value
        .Range("C11:C" & lastRow).Value = wsFrom.Range("C11:C" & lastRow).Value
        .Range("E11:E" & lastRow).Value = wsFrom.Range("D11:D" & lastRow).Value
        .Range("F11:F" & lastRow).Value = wsFrom.Range("E11:E" & lastRow).Value
        .Range("G11:G" & lastRow).Value = wsFrom.Range("F11:F" & lastRow).Value
        .Range("H11:H" & lastRow).Value = wsFrom.Range("G11:G" & lastRow).Value
        .Range("I11:I" & lastRow).Value = wsFrom.Range("H11:H" & lastRow).Value
    End With
End Sub


'転記先シートのシートモジュールに記載
Sub sheet2並べ替え()
'並べ替え
    With ThisWorkbook.Sheets("sheet2")
        .Range("A10").Sort _
                key1:=Range("H10"), order1:=xlAscending, _
                key2:=Range("F10"), order2:=xlAscending, _
                Header:=xlYes
        .Range("A10").Select
    End With
End Sub


'転記先シートのシートモジュールに記載
Sub 指定フォルダへ保存()
    'シートコピー
    '新規シートがアクティブになったとき転記イベントを抑止
    Application.EnableEvents = False
    ThisWorkbook.Sheets("sheet2").Copy
    Application.EnableEvents = True
    '新規ブックを格納
    Dim aWB As Workbook: Set aWB = ActiveWorkbook
    Dim aWS As Worksheet: Set aWS = ActiveSheet

    'パスを格納
    With aWS
        Dim savePath As String: savePath = .Range("K1").Value
        Dim backupPath As String: backupPath = .Range("K2").Value
        Dim saveName As String: saveName = Format(Now, "yyyy-mm-dd-hhmmss_") & .Range("K3").Value
        'パスを書いておいたセルを削除
        .Range("J1:K3").Clear
        .Range("A10").Select
    End With
    
    With aWB
        'xlsx形式で保存
        Application.DisplayAlerts = False
        .SaveAs savePath & "\" & saveName, FileFormat:=xlWorkbookDefault
        .SaveAs backupPath & "\" & saveName, FileFormat:=xlWorkbookDefault
        Application.DisplayAlerts = True
        .Close
    End With
    
    'フォルダを開く
    Shell "Explorer.exe " & savePath, vbNormalFocus
    Shell "Explorer.exe " & backupPath, vbNormalFocus
End Sub