How to combine Multiple Target functions with similar goals

0

The issue i am having is i want to create multiple timestamps. meaning one column target would update time in column A for example and 2nd column target would update time in column D for example. please help. i am soo close. Here is an example of my code. i am having issues with the "If intersect area" and well really i just dont no the way of VBA to make this happen.

Private Sub Worksheet_Change(ByVal Target As Range)

'Timestamp Data

'   TeachExcel.com

Dim myTableRange As Range

Dim myDateTimeRange As Range

Dim myUpdatedRange As Range

Dim myStockRange As Range

Dim myStockDateTimeRange As Range

'Your data table range

Set myTableRange = Range("G4:G2000")

Set myStockRange = Range("E4:E2000")

'Check if the changed cell is in the data tabe or not.

If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

'If Intersect(Target, myStockRange) Is Nothing Then Exit Sub

'Stop events from running

Application.EnableEvents = False

'Column for the date/time

Set myDateTimeRange = Range("M" & Target.Row)

'Column for last updated date/time

Set myUpdatedRange = Range("H" & Target.Row)

'Column for last updated stock date/time

Set myStockDateTimeRange = Range("F" & Target.Row)

'Determine if the input date/time should change

If myDateTimeRange.Value = "" Then

    myDateTimeRange.Value = Now

End If

'Update the updated date/time value

myUpdatedRange.Value = Now

'Update the date/time for stock

myStockDateTimeRange.Value = Now

'Turn events back on

Application.EnableEvents = True

End Sub

Answer
Discuss

Answers

0
Selected Answer

Here you go. Please replace your existing code with the code below.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 28 Jul 2019
    ' record date and time of data changes

    ' Control Panel ==============================================
    '               Set all your parameters here

    Const FirstDataRow As Long = 2                  ' set as appropriate
    ' list all columns where a change is to trigger a time stamp
    Const DataColumns1 As String = "A:A,F,J:H"
    Const DataColumns2 As String = "B:C,E,K:P"
    Const StampColumn1 As String = "D"              ' set as required
    Const StampColumn2 As String = "G"              ' set as required

    ' End of Control Panel =======================================


    Dim R As Long, C As Long
    Dim Rng As Range
    Dim i As Integer

    R = Target.Row                                  ' working variable
    Set Rng = DataRange(DataColumns1)               ' set for use in first loop
    C = Columns(StampColumn1).Column
    For i = 0 To 1
        If Not Application.Intersect(Target, Rng) Is Nothing Then
            ' skip execution if before first row or lower than last + 1
            If (R >= FirstDataRow) And (R <= LastUsedRow(Rng) + 1) Then
                ' suspend application events so that the change about to be
                ' made doesn't trigger a re-run of this procedure
                Application.EnableEvents = False
                With Cells(R, C)
                    .Value = Now()
                    ' set the numberformat to your preference here
                    .NumberFormat = "mm/dd/yy hh:ss"
                End With
                Application.EnableEvents = True
            End If

            ' skip the next loop if already done
            Exit For
        End If
        Set Rng = DataRange(DataColumns2)           ' change for use in 2nd loop
        C = Columns(StampColumn2).Column
    Next i
End Sub

Private Function DataRange(RngSpecs As String) As Range
    ' 28 Jul 2019

    Dim Sp() As String, Sp1() As String
    Dim i As Integer

    Sp = Split(Replace(RngSpecs, " ", ""), ",")
    For i = 0 To UBound(Sp)
        Sp1() = Split(Sp(i), ":")
        If UBound(Sp1) = 0 Then ReDim Preserve Sp1(1)
        If Len(Sp1(1)) = 0 Then Sp1(1) = Sp1(0)
        Sp(i) = Join(Sp1, ":")
    Next i
    Set DataRange = Range(Join(Sp, ","))
End Function

Private Function LastUsedRow(Rng As Range) As Long
    ' 28 Jul 2019

    Dim Fun As Long
    Dim Area As Range
    Dim C As Long

    For Each Area In Rng.Areas
        With Area
            For C = 0 To (.Columns.Count - 1)
                Fun = Application.Max(Fun, Cells(Rows.Count, (.Column + C)).End(xlUp).Row)
            Next C
        End With
    Next Area

    LastUsedRow = Fun
End Function

Much of the code is devoted to the support of the Control Panel I have marked for you at the top of the Change event procedure. All parameters must be entered there because it's bad programming to introduce parameters in the middle of the code. Code is easier to modify if you have a single place where all changes can be made.

There is one feature in your code which I have omitted from mine. This one:

If myDateTimeRange.Value = "" Then
    myDateTimeRange.Value = Now
End If

This code will prevent a time stamp from being applied if one already exists. In other words, the time stamp records when an entry was first made but not when it was last changed. I think the rule not to over-write an existing time stamp should come together with (a) a rule not to manually over-write any time stamp and/or (b) to prevent changes to existing data. Both of these ideas, separately or jointly, are not within the scope of your current code and would require another question here if they are to be added.

Discuss

Answer the Question

You must create an account to use the forum. Create an Account or Login