| 
    
     |  | こんな感じでも出来ると思います。 
 Sub MyData_Ave()
 Dim MyR As Range, C As Range
 
 Application.ScreenUpdating = False
 With Sheets("Sheet1")
 .Rows(1).Insert xlShiftDown
 .Range("A1:B1").Value = Array("日付", "Data")
 .Range("A1").Subtotal 1, xlAverage, 2, True
 Set MyR = .Range("B:B").SpecialCells(3)
 End With
 For Each C In MyR
 With Sheets("Sheet2").Range("A65536").End(xlUp)
 .Offset(1).Value = C.Offset(-1, -1).Value
 .Offset(1, 1).Value = C.Value
 End With
 Next
 With Sheets("Sheet1")
 .Range("A1").RemoveSubtotal
 .Rows(1).Delete xlShiftUp
 End With
 With Sheets("Sheet2")
 .Range("A65536").End(xlUp).Resize(, 2).ClearContents
 .Rows(1).Delete xlShiftUp
 .Activate
 End With
 Application.ScreenUpdating = True
 End Sub
 
 表のつもりなら、せめて項目ぐらい入れておくべきでしょう。
 
 |  |