Private Sub Worksheet_Change(ByVal Target As Range) With Target For i = 1 To .Count If .Cells(i).Row >= 4 And .Cells(i).Row <= 2000 And .Cells(i).Column = 2 Then .Cells(i).Offset(0, 2 + Day(Now)) = .Cells(i) End If Next i End With End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim tr, tc, k tr = Target.Row tc = Target.Column If tr >= 4 And tc = 2 Then Y = Date Set r1 = Rows(1).Find(Y, , , 1) If Not r1 Is Nothing Then k = r1.Column Cells(tr, tc + k - 2) = Cells(tr, tc) End If End If End Sub