How to fill a column conditionally - excel

Question

I have a dataset in which one of the columns needs to be filled conditionally. The conditions are that for equal lot numbers, the dates that are older (and equal) would be filled with 123ABC while dates that are newer (and equal) would be filled with 789XYZ. In the case of only one available date then it should be filled with 123ABC.
I tried the following code but it is filling the first 3 cells as 123ABC and rest of the cells as 789XYZ.
Please help.
Dim F As Worksheet
Set F = ThisWorkbook.Worksheets("Sheet1")
Dim i As Long: i = 0
Dim j As Long
Do While F.Range("C2").Offset(i, 0) <> ""
If F.Range("A2").Offset(i, 0) = "" Then
j = 0
Do While F.Range("C2").Offset(j, 0) <> ""
If (Abs(DateDiff("d", F.Range("C2").Offset(i, 0).Value, F.Range("C2").Offset(j, 0).Value)) <= 5) And (F.Range("B2").Offset(i, 0) = F.Range("B2").Offset(j, 0)) Then
F.Range("A2").Offset(i, 0).Value = "123ABC"
Else
F.Range("A2").Offset(i, 0).Value = "789XYZ"
GoTo Next_Blank
End If
j = j + 1
Loop
End If
Next_Blank:
i = i + 1
Loop
End Sub

Answer 1

Please, try the next approach. It should be very fast even for large ranges. It uses a dictionary to create "Lot" unique keys, keeping the value as the most recent Date. Then it uses arrays and works only in memory, dropping the processed array content at one, at the end of the code:
Sub FillColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in "B:B"
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item:
dict(arr(i, 2)) = IIf(CDate(arr(i, 3)) > CDate(dict(arr(i, 2))), CDate(arr(i, 3)), CDate(arr(i, 3)))
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2)) Then 'for a Date before existing one in column B:B:
arrFin(i, 1) = beforeD 'place the string beforeD
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
Edited:
Please, test the next version, which place "123ABC" if a single Date is found for the same "Lot", as required in your comment:
Sub FillColumn2()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
Dim arrExist
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item, and False for only one Date found:
If Not dict.Exists(arr(i, 2)) Then
dict.Add arr(i, 2), Array(CDate(arr(i, 3)), False) 'False means only one Date
Else
If CDate(arr(i, 3)) > dict(arr(i, 2))(0) Then
arrExist = dict(arr(i, 2)) 'place existing dictionary item in an array (to be changed)
arrExist(0) = CDate(arr(i, 3)): arrExist(1) = True 'True means that a second graiter Date has been found
dict(arr(i, 2)) = arrExist
End If
End If
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2))(0) Or dict(arr(i, 2))(1) = False Then 'check also the second item array element (boolean)
arrFin(i, 1) = beforeD 'place the string beforeD, also for the case of the same date
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
A dictionary can keep any data type, but it has a peculiarity: if the dictionary item is an array it cannot be modified directly in the item. That's why the code uses arrExist to take the dictionary item, modify it and place it back.
It is also good to know that Excel keeps a Date as a Long number. That's why comparing the existing dictionary item (when empty) with a lower number would never change the item. No date less then zero can be supplied...