VBA insert Week number and Date

Samhill62

Board Regular
Joined
Jun 2, 2016
Messages
54
Hi All,

I have the following code to generate a Week number in column A and a date in column B every time a cell is changed in column C of my spreadsheet. Unfortunately it does not work for multiple entries. For example, If I copy and paste a group of eight entries, it only updates the first row. How can I update the code to allow multiple entries to be updated at once?

Private Sub Worksheet_Change(ByVal Target As Range)
' Check if the edited cell is in column C and not the header row
If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then
' Add today's date to column B for the same row as the edited cell
Cells(Target.Row, "B").Value = Date
' Add the week number to column A for the same row as the edited cell
Cells(Target.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
End If
End Sub

Thanks in advance.
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Hi there

You can create a loop to loop through your range... I tested below and it does work if I change a value in C... I am just not sure how your data in C should look like but it worked for me... I have something similar in one of my projects so just had to update your code a bit to add the loop... Test and let us know if it is working...

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
    ' Check if the edited cells are in column C and not the header row
    If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then
        Application.EnableEvents = False
        For Each cell In Target ' Loop through changed cells and apply your week number and date
            ' Add today's date to column B for the same row as the edited cell
            Cells(cell.Row, "B").Value = Date
            ' Add the week number to column A for the same row as the edited cell
            Cells(cell.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
        Next cell
        Application.EnableEvents = True
    End If
End Sub
 
Upvote 0
Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range ' Check if the edited cells are in column C and not the header row If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then Application.EnableEvents = False For Each cell In Target ' Loop through changed cells and apply your week number and date ' Add today's date to column B for the same row as the edited cell Cells(cell.Row, "B").Value = Date ' Add the week number to column A for the same row as the edited cell Cells(cell.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1 Next cell Application.EnableEvents = True End If End Sub
Hi Jimmypop, spot on, works a treat. Many thanks.
 
Upvote 0
You could give this a try:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if the edited cell is in column C and not the header row

Dim rngC As Range
Set rngC = Intersect(Target, Range("C2:C200"))
If Not rngC Is Nothing Then
    ' Add today's date to column B for the same row as the edited cell
    rngC.Offset(0, -1).Value = Date
    ' Add the week number to column A for the same row as the edited cell
    rngC.Offset(0, -1).Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
End If
End Sub
 
Upvote 0
Solution
You could give this a try:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if the edited cell is in column C and not the header row

Dim rngC As Range
Set rngC = Intersect(Target, Range("C2:C200"))
If Not rngC Is Nothing Then
    ' Add today's date to column B for the same row as the edited cell
    rngC.Offset(0, -1).Value = Date
    ' Add the week number to column A for the same row as the edited cell
    rngC.Offset(0, -1).Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
End If
End Sub
Thanks Alex.
 
Upvote 0
Hi there

You can create a loop to loop through your range... I tested below and it does work if I change a value in C... I am just not sure how your data in C should look like but it worked for me... I have something similar in one of my projects so just had to update your code a bit to add the loop... Test and let us know if it is working...

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
    ' Check if the edited cells are in column C and not the header row
    If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then
        Application.EnableEvents = False
        For Each cell In Target ' Loop through changed cells and apply your week number and date
            ' Add today's date to column B for the same row as the edited cell
            Cells(cell.Row, "B").Value = Date
            ' Add the week number to column A for the same row as the edited cell
            Cells(cell.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
        Next cell
        Application.EnableEvents = True
    End If
End Sub
Hi Jimmypop, I Just had a thought, what would I need to add or change if I needed to specify a specific response? Say, the item in C2:C200 had to be "Good" to enable the code to display in columns A & B.
 
Upvote 0
Hi Jimmypop, I Just had a thought, what would I need to add or change if I needed to specify a specific response? Say, the item in C2:C200 had to be "Good" to enable the code to display in columns A & B.
Hi...

So you would only want to check for "Good" and nothing else? No numbers or other characters?
 
Upvote 0

I have had a look and you can add a additional check inside your loop... Maybe try:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    ' Check if the edited cells are in column C and not the header row
    If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then
        Application.EnableEvents = False
        For Each cell In Target
            ' Check if the value in column C is "Good"
            If cell.Value = "Good" Then
                ' Add today's date to column B for the same row as the edited cell
                Cells(cell.Row, "B").Value = Date
                ' Add the week number to column A for the same row as the edited cell
                Cells(cell.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
            End If
        Next cell
        Application.EnableEvents = True
    End If
End Sub
 
Upvote 0
Hi...

So you would only want to check for "Good" and nothing else? No numbers or other characters?
Correct.
I have had a look and you can add a additional check inside your loop... Maybe try:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    ' Check if the edited cells are in column C and not the header row
    If Not Intersect(Target, Range("C2:C200")) Is Nothing And Target.Row > 1 Then
        Application.EnableEvents = False
        For Each cell In Target
            ' Check if the value in column C is "Good"
            If cell.Value = "Good" Then
                ' Add today's date to column B for the same row as the edited cell
                Cells(cell.Row, "B").Value = Date
                ' Add the week number to column A for the same row as the edited cell
                Cells(cell.Row, "A").Value = WorksheetFunction.WeekNum(Date, vbMonday) - 1
            End If
        Next cell
        Application.EnableEvents = True
    End If
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,248
Members
452,623
Latest member
cliftonhandyman

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