With huge thanks to ZVI this now works brilliantly and VERY quickly. Here is the code used. Note that it will sort A-Z and cannot identify normalized word placement if it is not in consistent position within the cell.
Option Explicit
Option Compare Text
Sub Main()
' ZVI:2019-02-27
https://www.mrexcel.com/forum/excel-questions/1088801-find-partial-duplicate-values-column-2.html
Dim a(), b(), s1(), s2(), v
Dim i As Long, j As Long, k As Long, n As Long, m As Long, p As Long, pp As Long
Dim Rng As Range
Dim IsEmpty As Boolean
' Set data range A:D
With ActiveSheet.UsedRange
i = .Columns(1).Columns(1).Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, SearchFormat:=False).Row
Set Rng = .Offset(1).Resize(i - .Row).Columns("A:D")
End With
' Normalize Dataset
a() = Rng.Columns("B:C").Value
ReDim b(1 To UBound(a))
For i = 1 To UBound(b)
b(i) = TxtToArray(a(i, 1)) ' Array of normalized dataset
a(i, 1) = Join(b(i)) ' Normalized dataset
a(i, 2) = i ' Index
Next
' Disable screen updating
Application.ScreenUpdating = False
' Sort Rng by normalized Dataset
With Rng
.Columns("C:D").Value = a()
.Sort .Cells(1, "C"), xlAscending, Header:=xlNo
End With
'Main
a() = Rng.Columns("C:D").Value
p = a(1, 2)
For i = 1 To UBound(a) - 1
pp = a(i + 1, 2)
v = CompArrays(b(p), b(pp))
j = Abs(v)
Select Case v
Case Empty
' Equal
If j >= k Then
a(i, 1) = Join(b(p))
a(i, 2) = Empty
End If
a(i + 1, 1) = Join(b(pp))
a(i + 1, 2) = Empty
Case 0
' Not equal
If i = 1 Then
a(i, 1) = Join(b(p))
a(i, 2) = Empty
End If
a(i + 1, 2) = Empty
Case Else 'Is > 0, Is < 0
' j-word is not equal
If j >= k Then
m = 0
ReDim s(0 To UBound(b(p)) - 1)
For n = 0 To UBound(b(p))
If n <> j Then
s(m) = b(p)
m = m + 1
End If
Next
a(i, 1) = Join(s)
a(i, 2) = b(p)(j)
If v > 0 Then
a(i + 1, 1) = a(i, 1)
a(i + 1, 2) = b(pp)(j)
Else
a(i + 1, 1) = Join(b(pp))
a(i + 1, 2) = Empty
j = 0
End If
Else
If v > 0 Then
a(i + 1, 1) = Join(b(pp))
a(i + 1, 2) = Empty
End If
End If
End Select
p = pp
k = j
Next
' Put result
Rng.Columns("C:D").Value = a()
' Sort Rng by UID
With Rng
' **** Uncomment the next line to sort by UID ****
'.Sort .Cells(1, "A"), xlAscending, Header:=xlNo
End With
' Enable screen updating
Application.ScreenUpdating = True
End Sub
Function TxtToArray(Txt) As Variant
Dim a, i As Long, j As Long, s As String
Static RegEx As Object
If RegEx Is Nothing Then
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True
RegEx.Pattern = "[.,!?:;_]"
End If
s = RegEx.Replace(Txt, " ")
If s Like "*(* *)*" Then
While InStr(s, " ") > 0
s = Replace(s, " ", " ")
Wend
End If
a = Split(s)
j = 0
For i = 0 To UBound(a)
If Len(a(i)) > 0 Then
If a(i) <> "-" Then
a(j) = a(i)
j = j + 1
End If
End If
Next
If j - 1 < UBound(a) Then ReDim Preserve a(0 To j - 1)
TxtToArray = a
End Function
Function CompArrays(Arr1, Arr2) As Variant
' Compare arrays
' Returns:
' -n for index in Arr1 if SIZES found
' Empty for equal arrays
' 0 for different arrays
' n for index in Arr1 and Arr2 with different words
Const SIZES As String = "(XS)(S)(M)(L)(XL)(XXL)"
Dim i As Long, j As Long, n As Long
For i = 0 To UBound(Arr1)
If Arr1(i) Like ("(*)") Then
If InStr(1, SIZES, Arr1(i), vbTextCompare) > 0 Then
j = -i
If UBound(Arr2) >= i Then
If Arr2(i) Like ("(*)") Then
If InStr(1, SIZES, Arr2(i), vbTextCompare) > 0 Then
j = i
End If
End If
End If
Exit For
End If
End If
Next
If j = 0 Then
If UBound(Arr1) <> UBound(Arr2) Then
CompArrays = 0
Exit Function
End If
For i = 0 To UBound(Arr1)
If Arr1(i) <> Arr2(i) Then
j = i
n = n + 1
If n > 1 Then
CompArrays = 0
Exit Function
End If
End If
Next
End If
If j <> 0 Then CompArrays = j
End Function
