Nov 16 2021 08:13 PM - edited Nov 16 2021 08:45 PM
I have a dataset example - see attached. I want to be able to parse the dataset (by VBA, as there may be thousands of records) and determine whether a Product (Column B in the attachment) is unique (i.e. does not occur in any other row in a specific column) or, if not unique, flag if the duplicate is the latest instance based on the highest numeric value within a transaction ID (column D).
In a new column (Column G in the attachment), I would like to return TRUE where a Product is unique (i.e. does not occur in any other record) , OR if it is the latest instance of a Product (based on that numeric portion of the transaction ID). I have manually populated (in Column F) the logical result I would like to achieve by code in Column G.
Otherwise, return FALSE for that record.
I will use this value as part of an INDEX MATCH criteria from another worksheet to report on the latest instance of a given Product (where part of the MATCH will be whether the cell value is TRUE for a given row).
Cheers
Gerry
Nov 16 2021 09:01 PM
Solution
You may try the following code (placed on Module1 in the attached) to flag the Unique/Latest item in column F as you showed in the sample file.
Sub IdentifyUniqueOrLatestRecord()
Dim ws As Worksheet
Dim x As Variant
Dim dict As Object
Dim i As Long
Dim Trans As Long
Dim Flag As Variant
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
x = ws.Range("A1").CurrentRegion.Value
ReDim Flag(1 To UBound(x, 1) - 1, 1 To 1)
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 4), "-")(1))
If Not dict.exists(x(i, 2)) Then
dict.Item(x(i, 2)) = Trans
Else
If Trans > dict.Item(x(i, 2)) Then
dict.Item(x(i, 2)) = Trans
End If
End If
Next i
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 4), "-")(1))
If Trans = dict.Item(x(i, 2)) Then
Flag(i - 1, 1) = True
Else
Flag(i - 1, 1) = False
End If
Next i
ws.Range("A1").CurrentRegion.Columns(6).Offset(1).ClearContents
ws.Range("F2").Resize(UBound(Flag, 1), 1).Value = Flag
Application.ScreenUpdating = True
End Sub
Nov 16 2021 09:03 PM
Nov 16 2021 09:17 PM
Glad it worked as desired.
Nov 16 2021 09:19 PM
That worked brilliantly. If I can trouble you one more time - I've not played in arrays before, so just want to understand which values to adjust if my real-world workbook uses different column numbers.
I've updated the workbook by creating a new sheet (Sheet 2) by inserting a couple of extra columns (Product is now Column C, TransactionID is now Column F, result is now Column G).
Would you be able to advise how the code would adjust to work with those new columns?
Nov 16 2021 10:41 PM
No problem. I have added comments in the code so that you can tweak the code if the layout of your source data gets changed. Let me know if that works as desired.
Sub IdentifyUniqueOrLatestRecord()
Dim wsData As Worksheet
Dim x As Variant
Dim dict As Object
Dim i As Long
Dim Trans As Long
Dim Flag As Variant
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet2") 'Setting Sheet with Data
x = wsData.Range("A1").CurrentRegion.Value
ReDim Flag(1 To UBound(x, 1) - 1, 1 To 1)
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 6), "-")(1)) 'x(i,6) means Transaction Column F
If Not dict.exists(x(i, 3)) Then 'x(i,3) means Product Column C
dict.Item(x(i, 3)) = Trans
Else
If Trans > dict.Item(x(i, 3)) Then
dict.Item(x(i, 3)) = Trans
End If
End If
Next i
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 6), "-")(1))
If Trans = dict.Item(x(i, 3)) Then
Flag(i - 1, 1) = True
Else
Flag(i - 1, 1) = False
End If
Next i
'Writing output
'Columns(8) means Column H
wsData.Range("A1").CurrentRegion.Columns(6).Offset(1).ClearContents 'Clearing Column H to write the output
wsData.Range("H2").Resize(UBound(Flag, 1), 1).Value = Flag
Application.ScreenUpdating = True
End Sub
Nov 17 2021 01:02 AM
You Sir are awesome :)
One last question (I promise); if the transaction ID value was a numeric value (i.e. didn't require a split - per sheet 3 in the latest version of the worksheet), what would happen with the SPLIT lines?
Nov 17 2021 01:34 AM
For that scenario, you may try the following code...
Remember that this code sets Sheet3 as Sheet with source data.
Sub IdentifyUniqueOrLatestRecord3()
Dim ws As Worksheet
Dim x As Variant
Dim dict As Object
Dim i As Long
Dim Trans As Long
Dim Flag As Variant
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet3")
x = ws.Range("A1").CurrentRegion.Value
ReDim Flag(1 To UBound(x, 1) - 1, 1 To 1)
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
Trans = x(i, 6)
If Not dict.exists(x(i, 3)) Then
dict.Item(x(i, 3)) = Trans
Else
If Trans > dict.Item(x(i, 3)) Then
dict.Item(x(i, 3)) = Trans
End If
End If
Next i
For i = 2 To UBound(x, 1)
Trans = x(i, 6)
If Trans = dict.Item(x(i, 3)) Then
Flag(i - 1, 1) = True
Else
Flag(i - 1, 1) = False
End If
Next i
ws.Range("A1").CurrentRegion.Columns(10).Offset(1).ClearContents
ws.Range("J2").Resize(UBound(Flag, 1), 1).Value = Flag
Application.ScreenUpdating = True
End Sub
Nov 17 2021 01:56 AM
Nov 17 2021 04:07 AM
You're welcome @Kiwihiker! Glad I could help.
Nov 16 2021 09:01 PM
Solution
You may try the following code (placed on Module1 in the attached) to flag the Unique/Latest item in column F as you showed in the sample file.
Sub IdentifyUniqueOrLatestRecord()
Dim ws As Worksheet
Dim x As Variant
Dim dict As Object
Dim i As Long
Dim Trans As Long
Dim Flag As Variant
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
x = ws.Range("A1").CurrentRegion.Value
ReDim Flag(1 To UBound(x, 1) - 1, 1 To 1)
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 4), "-")(1))
If Not dict.exists(x(i, 2)) Then
dict.Item(x(i, 2)) = Trans
Else
If Trans > dict.Item(x(i, 2)) Then
dict.Item(x(i, 2)) = Trans
End If
End If
Next i
For i = 2 To UBound(x, 1)
Trans = VBA.Trim(Split(x(i, 4), "-")(1))
If Trans = dict.Item(x(i, 2)) Then
Flag(i - 1, 1) = True
Else
Flag(i - 1, 1) = False
End If
Next i
ws.Range("A1").CurrentRegion.Columns(6).Offset(1).ClearContents
ws.Range("F2").Resize(UBound(Flag, 1), 1).Value = Flag
Application.ScreenUpdating = True
End Sub