locked
Trouble With Creating a Two Datestamp Macro RRS feed

  • Question

  • I am creating a work sheet in Excel where I want to track Start and End dates of a particular transaction using two datestamps. The first datestamp column will show the date an entry was made and the other column will show the date when a person enters "Complete" from a drop down. Can someone help me?

    I found 2 VBA Codes that records date stamps. However, I don't know how to merge them so they will work in this sheet:

    Code 1 . It shows datestamp in "Received Date" column (D2) when you enter a transaction number in "Case Number" column (C2).

    Sub Timestamp1()

    Private Sub Worksheet_Change(ByVal Target As Range)

    Dim xCellColumn As Integer

    Dim xTimeColumn As Integer

    Dim xRow, xCol As Integer

    Dim xDPRg, xRg As Range

    xCellColumn = 3

    xTimeColumn = 4

    xRow = Target.Row

    xCol = Target.Column

    If Target.Text <> "" Then

        If xCol = xCellColumn Then

           Cells(xRow, xTimeColumn) = Now()

        Else

            On Error Resume Next

            Set xDPRg = Target.Dependents

            For Each xRg In xDPRg

                If xRg.Column = xCellColumn Then

                    Cells(xRg.Row, xTimeColumn) = "mm/dd/yyyy"

                End If

            Next

        End If

    End If

    End Sub

    Code 2 . It shows datestamp in "Completed Date" column (I2) when you select "Completed" from a drop down list in column (J2).

    Sub Timestamp2()

    Private Sub Worksheet_Change(ByVal Target As Range)

    Dim xCellColumn As Integer

    Dim xTimeColumn As Integer

    Dim xRow, xCol As Integer

    Dim xDPRg, xRg As Range

    xCellColumn = 10

    xTimeColumn = 9

    xRow = Target.Row

    xCol = Target.Column

    If Target.Text <> "" Then

        If xCol = xCellColumn Then

           Cells(xRow, xTimeColumn) = Now()

        Else

            On Error Resume Next

            Set xDPRg = Target.Dependents

            For Each xRg In xDPRg

                If xRg.Column = xCellColumn Then

                    Cells(xRg.Row, xTimeColumn) = "mm/dd/yyyy"

                End If

            Next

        End If

    End If

    End Sub

    Any help would be greatly appreciated.

    Brian


    8.0.3
    Sunday, July 19, 2020 3:56 PM

All replies

  • How about this?

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rng As Range
        Dim n As Long
        If Not Intersect(Range("C2,J2"), Target) Is Nothing Then
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            For Each rng In Intersect(Range("C2,J2"), Target)
                If rng.Value <> "" Then
                    If rng.Column = 3 Then
                        n = 1
                    Else
                        n = -1
                    End If
                    rng.Offset(0, n).Value = Now
                End If
            Next rng
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    Sunday, July 19, 2020 7:04 PM
  • Thank you so much for helping me to figure this out. I entered the the code you provided and I received an End Sub error so I removed the "Private Sub Worksheet_Change(ByVal Target As Range)" from both macros and now I'm getting a Run Time error 424 when the Debugger tries to execute these two commands:

    xRow = Target.Row

    xCol = Target.Column.

    Do you know how I can get around them?

    8.0.3
    Sunday, July 19, 2020 8:59 PM
  • You should remove both existing pieces of code, and replace them with the code that I posted.

    The lines that are causing problems do not occur in my version.


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    Sunday, July 19, 2020 9:10 PM
  •  

    You were right Hans!

    this formula works great and I only had to make one modification to extend the range. many thanks to you...

    Private Sub Worksheet_Change(ByVal Target As Range)

        Dim rng As Range

        Dim n As Long

        If Not Intersect(Range("C2:C500,J2:J500"), Target) Is Nothing Then

            Application.ScreenUpdating = False

            Application.EnableEvents = False

            For Each rng In Intersect(Range("C2:C500,J2:J500"), Target)

                If rng.Value <> "" Then

                    If rng.Column = 3 Then

                        n = 1

                    Else

                        n = -1

                    End If

                    rng.Offset(0, n).Value = Now

                End If

            Next rng

            Application.EnableEvents = True

            Application.ScreenUpdating = True

        End If

    End Sub

    8.0.3
    Sunday, July 19, 2020 11:33 PM