Создать несколько временных меток для значений соседних столбцов

Question

Я могу получить отметку времени в столбце C для значений столбца B.

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End Sub

Мне нужна отметка времени в столбце E для значений столбца D и, аналогично, отметка времени в столбце G для столбца Значения F.

Answer 1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim WorkRng As Range
Dim rng As Range
Dim xOffsetColumn As Integer
Dim rng1(1 To 18) As String
rng1(1) = "D:D"
rng1(2) = "M:M"
rng1(3) = "P:P"
rng1(4) = "R:R"
rng1(5) = "U:U"
rng1(6) = "W:W"
rng1(7) = "Z:Z"
rng1(8) = "AB:AB"
rng1(9) = "AE:AE"
rng1(10) = "AG:AG"
rng1(11) = "AL:AL"
rng1(12) = "AN:AN"
rng1(13) = "AQ:AQ"
rng1(14) = "AS:AS"
rng1(15) = "AV:AV"
rng1(16) = "AX:AX"
rng1(17) = "BA:BA"
rng1(18) = "BC:BC"

For I = 1 To 18
Set WorkRng = Intersect(Application.ActiveSheet.Range(rng1(I)), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each rng In WorkRng
        If Not VBA.IsEmpty(rng.Value) Then
            rng.Offset(0, xOffsetColumn).Value = Now
            rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
        Else
            rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next


    Application.EnableEvents = True
End If
Next I
End Sub