help with current date VBA code

J

Jagat Pavasia

Active Member
Joined
Mar 9, 2015
Messages
406
Office Version
  1. 2021
Platform
  1. Windows
I have VBA below
VBA Code: 
 Sub Macro2(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub



I want only date but in this vba code date and time display,
please help to only date
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
Jagat Pavasia said:
I have VBA below
VBA Code: 
 Sub Macro2(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub



I want only date but in this vba code date and time display,
please help to only date
Click to expand...





originally full VBA macro Below :

VBA Code: 
Private Sub worksheet_change(ByVal Target As Range)
    Macro1 Target
    Macro2 Target
    Macro3 Target
    Macro4 Target
    Macro5 Target
End Sub
Sub Macro1(Target As Range)
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ActiveSheet.Unprotect
 
  If Not Intersect(Range("C:C"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "DAY"
      GoTo EndSub
  End If
  If Not Intersect(Range("D:D"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "NIGHT"
      GoTo EndSub
  End If
  ' Else
  If Not Intersect(Target, Range("A4:M4")) Is Nothing Then
      If Target.Value = "" Then
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column
      Else
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column, Operator:=xlFilterValues, Criteria1:=CStr(Target.Value)
      End If
  End If
 
EndSub:
  ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFiltering:=True
  Application.EnableEvents = True
End Sub
 Sub Macro2(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro3(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -3
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub

 Sub Macro4(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -1
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Now
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro5(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Now
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub

VBA Code:





I want only date in "A" and only time in "B".
 
Upvote 0
Now gives Date & Time.
Date gives just the date and Time just the time.
However if you do want both Date & Time but in 2 fields it would be better to use Now and then split it so that you ensure they both refer to the exact same point it time.

PS: An alternative is that you could store date as a long and time as double

VBA Code: 
Sub test()

    Dim DateTime As Date
    Dim dt As Date
    Dim dTime As Date
    
    DateTime = Now
    dt = Int(DateTime)
    dTime = DateTime - dt
    
    Debug.Print dt
    Debug.Print dTime
    
End Sub
 
Upvote 0
Alex Blakenburg said:
Now gives Date & Time.
Date gives just the date and Time just the time.
However if you do want both Date & Time but in 2 fields it would be better to use Now and then split it so that you ensure they both refer to the exact same point it time.

PS: An alternative is that you could store date as a long and time as double

VBA Code: 
Sub test()

    Dim DateTime As Date
    Dim dt As Date
    Dim dTime As Date
   
    DateTime = Now
    dt = Int(DateTime)
    dTime = DateTime - dt
   
    Debug.Print dt
    Debug.Print dTime
   
End Sub
Click to expand...
I am New in VBA code please can you edit my VBA ?
please help me.

my current VBA code is Below :

VBA Code: 
Private Sub worksheet_change(ByVal Target As Range)
    Macro1 Target
    Macro2 Target
    Macro3 Target
    Macro4 Target
    Macro5 Target
End Sub
Sub Macro1(Target As Range)
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ActiveSheet.Unprotect
  
  If Not Intersect(Range("C:C"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "DAY"
      GoTo EndSub
  End If
  If Not Intersect(Range("D:D"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "NIGHT"
      GoTo EndSub
  End If
  ' Else
  If Not Intersect(Target, Range("A4:M4")) Is Nothing Then
      If Target.Value = "" Then
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column
      Else
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column, Operator:=xlFilterValues, Criteria1:=CStr(Target.Value)
      End If
  End If
  
EndSub:
  ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFiltering:=True
  Application.EnableEvents = True
End Sub
 Sub Macro2(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro3(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -3
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        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"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub

 Sub Macro4(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -1
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Now
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro5(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Now
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub




[ATTACH type="full" width="665px"]113051[/ATTACH]
 

Attachments

  • 12.JPG
    12.JPG
    254.7 KB · Views: 6
Upvote 0
Try this:
VBA Code: 
Private Sub worksheet_change(ByVal Target As Range)
    Macro1 Target
    Macro2 Target
    Macro3 Target
    Macro4 Target
    Macro5 Target
End Sub
Sub Macro1(Target As Range)
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ActiveSheet.Unprotect
  
  If Not Intersect(Range("C:C"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "DAY"
      GoTo EndSub
  End If
  If Not Intersect(Range("D:D"), Target) Is Nothing _
    And Target.Value = "**" Then
      Target.Value = "NIGHT"
      GoTo EndSub
  End If
  ' Else
  If Not Intersect(Target, Range("A4:M4")) Is Nothing Then
      If Target.Value = "" Then
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column
      Else
          ActiveSheet.Range("A6:M6").AutoFilter Field:=Target.Column, Operator:=xlFilterValues, Criteria1:=CStr(Target.Value)
      End If
  End If
  
EndSub:
  ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFiltering:=True
  Application.EnableEvents = True
End Sub
 Sub Macro2(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Date
                rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro3(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -3
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Date
                rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub

 Sub Macro4(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("C6:C36"), Target)
    xOffsetColumn = -1
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Time
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 Sub Macro5(Target As Range)
Dim WorkRng As Range
    Dim rng As Range
    Dim xOffsetColumn As Integer


    Set WorkRng = Intersect(Application.ActiveSheet.Range("d6:d36"), Target)
    xOffsetColumn = -2
    If Not WorkRng Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo exit_proc
        Me.Unprotect
        For Each rng In WorkRng
            If Not VBA.IsEmpty(rng.Value) Then
                rng.Offset(0, xOffsetColumn).Value = Time
                rng.Offset(0, xOffsetColumn).NumberFormat = "h:mm AM/PM"
            Else
                rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
exit_proc:
    Me.Protect
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

N
  • Question Question
VBA - Intersect code being re-initiated
Replies
1
Views
189
Peter_SSs
Peter_SSs
O
  • Question Question
Multiple VBA codes on sheet1
Replies
1
Views
343
skillilea
S
L
  • Solved
Combining Worksheet Changes
Replies
3
Views
302
Joe4
Joe4
L
  • Question Question
Input date when cell changes even if via another referenced cell.
Replies
3
Views
774
Micron
M
B
  • Question Question
Action on cell C1 when cell B1 changes with function
2 3
Replies
29
Views
2K
belodelokelo
B

Forum statistics

Threads
1,223,885
Messages
6,175,183
Members
452,615
Latest member
bogeys2birdies

Share this page

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