Auto insert date in two cells problem

Tucup

New Member
Joined
Sep 25, 2018
Messages
6
Good afternoon,

I am really rubbish with VBA so please forgive my code errors. , I have a worksheet where I have a drop down list (A), once selected it puts the date and time in a cell, 2 cells to the right(C). In the same Row I have another cell(F), that if data is present, it puts the time into a cell, 2 cells to the left(D). As I add more rows, it is replicated as my list grows It was originally two separate scripts but due to an error I had to merge them. It worked for a while but now every time I click on a new Row, even with no data in (F) it puts the TIME in (D) and runs off down the page.
Can someone please help


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Tucup 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("A:A")) Is Nothing) Then _
Target.Offset(0, 2) = Now()
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("A:A"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 2) = Now()
Next
End If
Application.EnableEvents = True
End If
Dim rInt As Range
Dim rCell As Range
Dim tCell As Range

Set rInt = Intersect(Target, Range("F:F"))
If Not rInt Is Nothing Then
For Each rCell In rInt
Set tCell = rCell.Offset(0, -2)
If IsEmpty(tCell) Then
tCell = Time
'tCell.NumberFormat = "hh:mm"
End If
Next
End If

End Sub
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Check if this helps you, otherwise, explain step by step what is the sequence you need.


Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim c As Range
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For Each c In Target
            c.Offset(0, 2) = Now()
        Next
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        For Each c In Target
            If c.Offset(0, -2) = "" Then c.Offset(0, -2) = Now()
        Next
    End If
End Sub
 
Upvote 0
Hi Dante,
Thanks for the quick reply. Here is a screen capture below. What I hoped to have is in the top section ( I have a button that copies data from a second worksheet to the main worksheet = DAY)
This is fine. What I get should be the middle section you see below. As I put data in (Column A dropdown list) the script should then detect data in that cell and put the date in Column C. Then when I move over to Column F and enter data, Column D gets the TIME inserted. Unfortunately, the part that controls F & D seems to populate the whole column.
 
Last edited by a moderator:
Upvote 0
Hi Dante,
Thanks for the quick reply.

Sorry I tried to include a screen capture and could not delete it.

What I was hoping for was to only put the date in if there was data in the corresponding cells. So if I put data (TEXT) into column A, column C would put the date in. Similarly, If data was put into F then the time would appear in D.

A B C D E F G
Hello 18.07.2019 18:45 Hello
18:49 Hello
Hello 19:07.2019


Does this seem plausible?
 
Upvote 0
Hi Dante,
Thanks for the quick reply.

Sorry I tried to include a screen capture and could not delete it.

What I was hoping for was to only put the date in if there was data in the corresponding cells. So if I put data (TEXT) into column A, column C would put the date in. Similarly, If data was put into F then the time would appear in D.

A B C D E F G
Hello 18.07.2019 18:45 Hello
18:49 Hello
Hello 19:07.2019
Does this seem plausible?


If you are going to capture several data at the same time in the columns:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim c As Range
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For Each c In Target
            Cells(c.Row, "C").Value = Date
        Next
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        For Each c In Target
            Cells(c.Row, "D").Value = Time
        Next
    End If
End Sub


----------------------------------------
If you only capture one data:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Cells(Target.Row, "C").Value = Date
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Cells(Target.Row, "D").Value = Time
    End If
End Sub


---A variant:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A, F:F")) Is Nothing Then
        If Target.Column = 1 Then Target.Offset(, 2) = Date Else Target.Offset(, -2) = Time
    End If
End Sub
 
Upvote 0
If you are going to capture several data at the same time in the columns:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim c As Range
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For Each c In Target
            Cells(c.Row, "C").Value = Date
        Next
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        For Each c In Target
            Cells(c.Row, "D").Value = Time
        Next
    End If
End Sub


I like this very much. I still get an error though. Even though there is no data in the cells, it still puts the date and time in. I think it sees copied range of empty cells as a form or data even though it has no text in it. Sorry to take up your time. Is it possible to only insert Date & Time if no text is in the cell? No Date or Time if the cell has no text.



Tucup
 
Upvote 0
I like this very much.

I still get an error though. What error message does the macro send and on which line does it stop?


Is it possible to only insert Date & Time if no text is in the cell? If there is no text, in which cell? in the destination cells (columns C and D)? Or in the modified cells columns (A and F)?

Tucup

Try this:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        If Cells(Target.Row, "C").Value = "" Then Cells(Target.Row, "C").Value = Date
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        If Cells(Target.Row, "D").Value = "" Then Cells(Target.Row, "D").Value = Time
    End If
End Sub
 
Upvote 0
Try this:

Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        If Cells(Target.Row, "C").Value = "" Then Cells(Target.Row, "C").Value = Date
    End If
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        If Cells(Target.Row, "D").Value = "" Then Cells(Target.Row, "D").Value = Time
    End If
End Sub

Wow.... I have just got home and saw your reply. Fantastic, it works great. I have tried to force it to break but it is stable thanks to you DanteAmor.
Thankyou.
 
Upvote 0
Wow.... I have just got home and saw your reply. Fantastic, it works great. I have tried to force it to break but it is stable thanks to you DanteAmor.
Thankyou.

I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,954
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top