When appending unique values in array to an excel range, highlight the cell if it is a duplicate - excel

Question

I have an array of values result that I got from a REST API call - result = [1,2,3,4,5] and they are parsed in as variant in the AppendUnique function.
What I want to do:
AppendUnique function appends unique values from a growing result array to a range in excel. I want to add a new feature to AppendUnique, where the repeated values in the result array will be highlighted in the excel cell.
Explanation on my current code:
In the beginning
I input each value in the array result to populate cells from A1 to A5 (the range is dynamic, based on the number of values in the array, so might not be A5 all the time).
So, if the range (A1-A100) is empty, we populate the cells normally.
^ this part is completed
As the result array grows
Since the result will increase as we run the Macro again, for example, 15 minutes later the result may become [1,2,3,4,5,6,7,8]
So, if the range (A1-A5) is not empty, we append the array's additional items at the back of the cell range, if they do not appear in the range (meaning they are additional ones)
^ this part is completed
The result may also contain duplicates, for example, 30 minutes later, the result may become [1,2,3,4,5,6,7,8,3], where 3 is the duplicate.
If there is duplicate - 3, the cell A3 (where we populated 3) needs to be highlighted.
^ this question is about this part
My current code:
Sub AppendUnique( _
Arr() As Variant, _
ByVal ws As Worksheet, _
ByVal FirstCellAddress As String, _
Optional ByVal OverWrite As Boolean = False)
' Write the data from the source range to the source array ('sData').
' Reference the first destination cell ('fCell').
If ws.FilterMode Then ws.ShowAllData
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim sData() As Variant, srCount As Long
With fCell
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
srCount = lCell.Row - .Row + 1
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
Else
sData = .Resize(srCount).Value
End If
If Not OverWrite Then Set fCell = lCell.Offset(1)
End If
End With
' Write the unique data from the source array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sr As Long
For sr = 1 To srCount: dict(CStr(sData(sr, 1))) = Empty: Next sr
Erase sData
' Define the destination array ('dData').
Dim lb As Long: lb = LBound(Arr)
Dim ub As Long: ub = UBound(Arr)
Dim dData() As Variant: ReDim dData(1 To ub - lb + 1, 1 To 1)
' Check the values from the given array ('Arr') against the values
' in the dictionary and write the non-matches to the destination array.
Dim dr As Long, c As Long, cString As String
For c = lb To ub
cString = CStr(Arr(c))
If Len(cString) > 0 Then ' is not blank
If Not dict.Exists(cString) Then ' is not in the dictionary
dict(cString) = Empty ' prevent dupes from the given array
dr = dr + 1
dData(dr, 1) = cString
End If
End If
Next c
If dr = 0 Then
MsgBox "No new values found.", vbExclamation
Exit Sub
End If
' Write the values from the destination array to the destination range.
fCell.Resize(dr).Value = dData
If OverWrite Then ' clear below
fCell.Resize(ws.Rows.Count - fCell.Row - dr + 1).Offset(dr).Clear
End If
' Inform.
MsgBox "Data appended.", vbInformation
End Sub
I initially thought maybe I can do something under the line - If Len(cString) > 0 Then, to add If dict. Exists(cstring) Then, highlight the cell by doing something like interior.color = vbYellow.
However, I realised that in my current code, the products are appended altogether after checking the repeated items, so I am not exactly sure how to highlight the cell of repeated value, since we are not looping over the appended range.
Any help would be greatly appreciated, thanks in advance.

Answer 1

Use the dictionary value to store a reference to the relevant row. The complication is to differentiate between existing keys from the sheet and those added from the array. For the Overwrite mode the values from the sheet become obsolete. I have used a concatenated string of the row offset and either ";sht" or ";arr". It is easy to separate the 2 values with split().
To identify duplicate in the array I have added another dictionary - dupl.
Sub AppendUnique( _
Arr() As Variant, _
ByVal ws As Worksheet, _
ByVal FirstCellAddress As String, _
Optional ByVal OverWrite As Boolean = False)
If ws.FilterMode Then ws.ShowAllData
Dim fCell As Range, lCell As Range, tcell As Range
Dim sData() As Variant, srCount As Long
' Write the data from the source range to the source array ('sData').
' Reference the first destination cell ('fCell').
Set fCell = ws.Range(FirstCellAddress)
If Len(fCell) = 0 Then
srCount = 0
' target cell for appending new items
Set tcell = fCell
fCell.ClearFormats
Else
Set lCell = ws.Cells(ws.Rows.Count, fCell.Column).End(xlUp)
srCount = lCell.Row - fCell.Row + 1
If srCount > 1 Then
sData = fCell.Resize(srCount).Value2
Else
ReDim sData(1 To 1, 1 To 1):
sData(1, 1) = fCell.Value2
End If
' clear any existing coloring
fCell.Resize(srCount).ClearFormats
' target cell for appending new items
Set tcell = lCell.Offset(1)
End If
' Write the unique data from the source array to a dictionary.
Dim dict As Object, sr As Long, r As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
r = 0 ' row offset
If srCount > 0 Then
For sr = 1 To UBound(sData)
dict(CStr(sData(sr, 1))) = r & ";sht" ' fcell row offset +1
r = r + 1
Next sr
End If
' reset target cell
If OverWrite Then
Set tcell = fCell
r = 0
End If
' Define the destination array ('dData').
Dim lb As Long, ub As Long
Dim dr As Long, c As Long, cString As String
Dim dData() As Variant:
lb = LBound(Arr)
ub = UBound(Arr)
ReDim dData(1 To ub - lb + 1, 1 To 1)
' Check the values in Arr
' against the values in the dictionary and
' write the non-matches to the destination array.
Dim dupl As Object, k
Set dupl = CreateObject("Scripting.Dictionary")
For c = lb To ub
' dictionary key
k = CStr(Arr(c))
If Len(k) > 0 Then ' is not blank
If Not dict.Exists(k) Then
' is not in the dictionary
' prevent dupes from the given array
dict(k) = r & ";arr ' store fcell offset"
r = r + 1
dr = dr + 1
dData(dr, 1) = k
End If
' check for duplicates in arr
If dupl.Exists(k) Then
dupl(k) = dupl(k) + 1
Else
dupl.Add k, 1
End If
End If
Next c
' clear existing data
If OverWrite And srCount > 0 And dr > 0 Then
fCell.Resize(srCount).Clear
End If
' Write the values from the destination array
' to the destination range.
If dr > 0 Then
tcell.Resize(dr).Value = dData
End If
' highligh if duplicate
Dim ar
For Each k In dupl.keys
If dupl(k) > 1 Then
ar = Split(dict(k), ";")
r = ar(0)
If dr > 0 And OverWrite And ar(1) = "sht" Then
' do nothing as row information is useless
' for existing value with overwrite
Else
fCell.Offset(r).Interior.Color = RGB(255, 255, 0)
End If
End If
Next
If dr = 0 Then
MsgBox "No new values found.", vbExclamation
Else
' Inform.
MsgBox dr & " Data rows appended.", vbInformation
End If
End Sub