Я думаю, что вы можете сделать это с помощью формул.
Если вы обеспокоены тем, что пользователи изменяют формулу, используйте Table (и, возможно, даже защитите столбец формулы, хотя для этого потребуетсяКод VBA, позволяющий расширить таблицу). Таким образом, диапазоны будут динамически настраиваться на добавление и удаление данных, и пользователям не нужно будет редактировать формулу:
С таблицей, переименованной Fruits, и столбцами, названными как на скриншоте:
=IFERROR(AGGREGATE(14,6,1/(([@Fruit]=[Fruit])*([@Value]<>[Value]))*[Value],1),"")
Использование условного форматирования для форматирования ячеек
РЕДАКТИРОВАНИЕ: Я думаю, что табличный подход даствам лучшее решение, но для подхода VBA я бы использовал словарь и набор различных значений, связанных с фруктами.
Предполагая, что ваш первый столбец называется "Фрукт" (или что-то, что вы можете использовать в Find, или даже известный адрес), вы можете использовать следующее для создания столбца альтернативных значений для каждого элемента.
'Add reference to Microsoft Scripting Runtime
' or use late binding
Option Explicit
Sub diffs()
Dim myD As Dictionary
Dim vData As Variant
Dim rData As Range, C As Range
Dim wsSrc As Worksheet
Dim I As Long, V As Variant
Dim colVals As Collection
'Find the table
Set wsSrc = Worksheets("sheet2") 'or wherever
With wsSrc.Cells
Set C = .Find(what:="Fruit", after:=.Item(1, 1), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not C Is Nothing Then
With wsSrc
Set rData = .Range(C, .Cells(.Rows.Count, C.Column).End(xlUp)).Resize(columnsize:=3)
vData = rData
End With
Else
MsgBox "No data table"
Exit Sub
End If
End With
'Collect the data into a dictionary
'Max 2 different values per fruit
Set myD = New Dictionary
myD.CompareMode = TextCompare
For I = 2 To UBound(vData)
If Not myD.Exists(vData(I, 1)) Then
Set colVals = New Collection
colVals.Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
myD.Add Key:=vData(I, 1), Item:=colVals
Else
On Error Resume Next 'omit duplicate values
myD(vData(I, 1)).Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
On Error GoTo 0
End If
Next I
'Populate column 3
For I = 2 To UBound(vData, 1)
Set colVals = myD(vData(I, 1))
vData(I, 3) = ""
If colVals.Count > 1 Then
For Each V In colVals
If V <> vData(I, 2) Then vData(I, 3) = V
Next V
End If
Next I
Application.ScreenUpdating = False
With rData
.Clear
.Value = vData
For I = 2 To UBound(vData)
If vData(I, 3) <> "" Then
With rData.Cells(I, 1)
.Font.Color = vbWhite
.Font.Bold = True
.Interior.Color = vbRed
End With
End If
Next I
End With
End Sub