VBA insert Week number and Date

[Samhill62]

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.

 

[Jimmypop]

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...

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

 

[Samhill62]

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.

 

[Alex Blakenburg]

You could give this a try:

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

 

[Samhill62]

You could give this a try:

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.

 

[Samhill62]

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...

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.

 

[Jimmypop]

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?

 

[Samhill62]

Hi...

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

Correct.

 

[Jimmypop]

Correct.

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

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

 

[Samhill62]

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:

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