Need Macro to calculate week ending date and override cell

[powerpivotlegal]

Hello,

I was hoping there was a macro that could calculate the week ending date for a cell and then override the data in the same cell with the correct week-ending date.

So if a user input the date as 1/20/16, the macro would automatically execute and override that date and change it to 1/23/16 (i.e. the week-ending date).

All I have so far is the following:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.cells <> "" Then
A2+7-WEEKDAY(A2,1)
End If
End Sub

Many thanks

 

[Fishboy]

Hello,

I was hoping there was a macro that could calculate the week ending date for a cell and then override the data in the same cell with the correct week-ending date.

So if a user input the date as 1/20/16, the macro would automatically execute and override that date and change it to 1/23/16 (i.e. the week-ending date).

All I have so far is the following:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.cells <> "" Then
A2+7-WEEKDAY(A2,1)
End If
End Sub

Many thanks

Hi powerpivotlegal,

I found the following custom function in the Microsoft library online:

Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
    ' Returns the last day in the week specified by
    ' the date in dtmDate.
    ' Uses localized settings for the first day of the week.
    If dtmDate = 0 Then
        ' Did the caller pass in a date? If not, use
        ' the current date.
        dtmDate = Date
    End If
    dhLastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 6
End Function

If you add the above to a standard module, you can then amend you worksheet_change event macro as follows:

Private Sub Worksheet_Change(ByVal Target As Range)
' If you update a cell in column A and the value is not blank then
    If Not Intersect(Target, Range("A:A")) Is Nothing And Target.Value <> "" Then
' Disable events to prevent infinite loop issues
        Application.EnableEvents = False
' Update the target value by calling the custom function and work out the last day of the week
            Target.Value = dhLastDayInWeek(Target.Value)
' Re-enable events
        Application.EnableEvents = True
    End If
End Sub

You can obviously change the desired column from A:A to whatever column(s) you wish.

 

[powerpivotlegal]

Thanks Fishboy but the macro does not seem to execute. I've put the code for the function and the macro in separate modules and in the same module and date does not recalculate to the week ending date when you enter 1/20/16. It just leaves the cell as 1/20/16.

 

[Fishboy]

Thanks Fishboy but the macro does not seem to execute. I've put the code for the function and the macro in separate modules and in the same module and date does not recalculate to the week ending date when you enter 1/20/16. It just leaves the cell as 1/20/16.

Hmm, just to clarify, the function goes in a standard module, doesn't matter which one or what that module is called, just so long as it is in the same workbook.

The Worksheet_Change macro goes directly on the backend of whatever sheet you want to apply it to, so if it was Sheet1 you would right-click on the Sheet1 tab name and select View Code and paste it in there.

Here it is in action. An otherwise blank workbook with only one sheet. Just put a date in any cell in column A and it should work.

 

[powerpivotlegal]

Dropbox file wouldn't open for me but I was able to get to get it to work. Tweaked it to make the week-ending date a Saturday and combined it with another macro that hides the row. It seems to execute both macros. Unless you see anything wrong I'm going to roll with this. Thanks again for all your help.

Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the last day in the week specified by
' the date in dtmDate.
' Uses localized settings for the first day of the week.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
End Function
Sub main()

Private Sub Worksheet_Change(ByVal Target As Range)
' If you update a cell in column H and the value is not blank then
If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
' Disable events to prevent infinite loop issues
Application.EnableEvents = False
' Update the target value by calling the custom function and work out the last day of the week
Target.Value = dhLastDayInWeek(Target.Value)
' Re-enable events
Application.EnableEvents = True
End If

If Not Intersect(Target, Range("J:J")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "x" Or Target.Value = "X" Then
Rows(Target.Row).Hidden = True
End If
End If

End Sub

 

[Fishboy]

Dropbox file wouldn't open for me but I was able to get to get it to work. Tweaked it to make the week-ending date a Saturday and combined it with another macro that hides the row. It seems to execute both macros. Unless you see anything wrong I'm going to roll with this. Thanks again for all your help.

Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
    ' Returns the last day in the week specified by
    ' the date in dtmDate.
    ' Uses localized settings for the first day of the week.
    If dtmDate = 0 Then
        ' Did the caller pass in a date? If not, use
        ' the current date.
        dtmDate = Date
    End If
    dhLastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
End Function
Sub main()

Private Sub Worksheet_Change(ByVal Target As Range)
' If you update a cell in column H and the value is not blank then
    If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
' Disable events to prevent infinite loop issues
        Application.EnableEvents = False
' Update the target value by calling the custom function and work out the last day of the week
            Target.Value = dhLastDayInWeek(Target.Value)
' Re-enable events
        Application.EnableEvents = True
    End If
    
If Not Intersect(Target, Range("J:J")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "x" Or Target.Value = "X" Then
Rows(Target.Row).Hidden = True
End If
End If

End Sub

Hi again powerpivotlegal, sorry for the delay in my reply.

As far as I can see the above code should be fine. I am glad to hear you found a suitable solution

 

[powerpivotlegal]

Hi Fishboy,

My IT manager inserted some code to eliminate a bug that kept appearing when testing. However, the macro still gives out a run-time error 13, type mismatch when you delete a row from the formatted table or try to auto-fill (i.e. double-clicking or mass copy/paste) the week-ending date column.

My IT manager says I need a loop code or error handler, but I have no idea what code or parameters should be added.

Updated code below.

Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the last day in the week specified by
' the date in dtmDate.
' Uses localized settings for the first day of the week.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Columns.Count = 16384 Then
Exit Sub
End If

' If you update a cell in column H and the value is not blank then
If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
' Disable events to prevent infinite loop issues
Application.EnableEvents = False
' Update the target value by calling the custom function and work out the last day of the week
Target.Value = dhLastDayInWeek(Target.Value)
' Re-enable events
Application.EnableEvents = True
End If

If Not Intersect(Target, Range("J:J")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "x" Or Target.Value = "X" Then
Rows(Target.Row).Hidden = True
End If
End If

End Sub

Thanks.