How to fill a column conditionally-CodePudding

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

CodePudding user response：

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