シート間の転記

Sub セルをシート3にコピー()
    Dim シート1 As Worksheet
    Dim シート3 As Worksheet
    Dim 最終行 As Long
    Dim 現在日付 As String
    
    ' シート1とシート3のワークシートを取得
    Set シート1 = ThisWorkbook.Sheets("Sheet1")
    Set シート3 = ThisWorkbook.Sheets("Sheet3")
    
    ' シート3の最終行を取得
    最終行 = シート3.Cells(シート3.Rows.Count, 1).End(xlUp).Row
    
    ' 現在の日付を取得
    現在日付 = Format(Date, "yyyy-mm-dd")
    
    ' シート1のB3、B6、B9、B12、B20をシート3にコピー
    シート1.Range("B3").Copy シート3.Cells(最終行 + 1, 2)
    シート1.Range("B6").Copy シート3.Cells(最終行 + 1, 3)
    シート1.Range("B9").Copy シート3.Cells(最終行 + 1, 4)
    シート1.Range("B12").Copy シート3.Cells(最終行 + 1, 5)
    シート1.Range("B20").Copy シート3.Cells(最終行 + 1, 9)
    
    ' シート1のB12からB15の範囲を取得
    Dim コピー範囲 As Range
    Set コピー範囲 = シート1.Range("B12:E15")
    
    ' B12からB15の範囲をループして空白でないセルをシート3にコピー
    Dim セル As Range
    Dim 列オフセット As Long
    
    列オフセット = 4
    
    For Each セル In コピー範囲
        
        If セル.Value <> "" Then
            
            列オフセット = 列オフセット + 1
            
            セル.Copy シート3.Cells(最終行 + 1, 列オフセット)
        
        End If
    
    Next セル
    
    ' シート3に日付を入力
    シート3.Cells(最終行 + 1, 1).Value = 現在日付
    
    ' メッセージボックスを表示
    MsgBox "データがシート3にコピーされました。", vbInformation
    
End Sub