Add 1 day to todays date whenever value gets repeated

lwaol

New Member
Joined
Mar 18, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
I have a problem that I hope you can help me with.

The below code adds 1 day to todays day in Column B if it finds a repeated value in column A. However I want it to add 2 days if it gets repeated again and so on.

I have tried to illustrate how the codes work in the attached picture. So what I want is cell B10 in the picture to be 20/03/2021. I need to make it automatic so it can run for any number of repeated values.



Screenshot vba.png


Sub Add_date()

Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row

For iCntr = 2 To lastRow

If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)

If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = Date + 1

Else
Cells(iCntr, 2) = Date
End If

End If

Next

End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
I'm using Dictionary here because it has built in function to check if certain value is already existed in database. Everything is stored in Dictionary dDate. It will store existing value and latest date related to the Value. I think it is easier this way.

VBA Code:
Sub AddDate()

Dim rowLast As Long, iCntr As Long
Dim dDate As Object

Set dDate = CreateObject("Scripting.Dictionary")

rowLast = Range("A" & Rows.Count).End(xlUp).Row

For iCntr = 2 To rowLast
    If Not dDate.Exists(Range("A" & iCntr).Value2) Then
        dDate.Add Range("A" & iCntr).Value2, Date
        Range("B" & iCntr) = Date
    Else
        Range("B" & iCntr) = dDate(Range("A" & iCntr).Value2) + 1
        dDate(Range("A" & iCntr).Value2) = Range("B" & iCntr)
    End If
Next

Set dDate = Nothing

End Sub
 
Upvote 0
Solution
Thank you so much Zot for the fast reply and the code works. I will look into the use of Dictionary.
 
Upvote 0

Forum statistics

Threads
1,213,521
Messages
6,114,109
Members
448,548
Latest member
harryls

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