Check set of number with conditions

[YasserKhalil]

Hello everyone
I have some sets of numbers in column A
For example: this set 42-85-28-5-30
in this set, it is correct because, 42 and 28 all have the number 2, 85 and 5 are also having same number 5 then 30 appears to be different and standing alone. In other words, if there are four numbers that have similarity and only one number is different and unique .. then to take this set in the result or check it as True

Another example: this set 42-43-44-45-10
All the numbers have the 4 in and 10 is different and unique so it is True and correct

Another example: this set 42-43-40-45-10
These numbers 10 and 40 are similar in 0 and the other three numbers have 4 so this set is not true and this doesn't to be included in the results

Thanks advanced for help

[Trebor76]

Hi Yasser,

See how this goes:

Option Explicit
Sub Macro1()

    Dim strNums() As String
    Dim strLineOfNums As String
    Dim i As Long, j As Long, k As Long
    Dim lngCountOfChar As Long, lngLenOfChar As Long
    Dim lngMyRow As Long
    Dim blnInclude As Boolean
    
    Application.ScreenUpdating = False
    
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        blnInclude = False
        strLineOfNums = Replace(Range("A" & lngMyRow), "-", "")
        strNums = Split(Range("A" & lngMyRow), "-")
        For i = LBound(strNums) To UBound(strNums)
            For j = 1 To Len(strNums(i))
                lngLenOfChar = Len(strNums(i))
                lngCountOfChar = 0
                For k = 1 To lngLenOfChar
                    lngCountOfChar = lngCountOfChar + Len(strLineOfNums) - Len(Replace(strLineOfNums, Mid(strNums(i), k, 1), ""))
                Next k
                'If each digit in the number is only in the string once i.e. the count of each digit is equal to the length of the number, then...
                If lngLenOfChar = lngCountOfChar Then
                    '...exit the loop as it's unique and we want the string in our results
                    blnInclude = True
                    Exit For
                End If
            Next j
        Next i
        'If the string is to be included in our results, then...
        If blnInclude = True Then
            '...colour rhe cell green (change to suit)
            Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0)
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

[YasserKhalil]

Thanks a lot for great help Trebor
Please put this set in the test for sets 49-75-33-2-31
You will find it is highlighted. There are 33 and 31 similar so there are 2 and 75 and 49 unique. That set doesn't included as the logic four similar numbers and only one unique

[Trebor76]

So if only one is unique it is to be highlighted?

[YasserKhalil]

Yes that's right my friend. Four similar numbers plus one unqiue.

[jindon]

Function UniqDigits(ByVal txt As String) As Boolean
    Dim e, x, i As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    x = Split(txt, "-")
    With CreateObject("Scripting.Dictionary")
        For Each e In x
            For i = 1 To Len(e)
                If Not dic.exists(Mid$(e, i, 1)) Then
                    .Item(Mid$(e, i, 1)) = .Item(Mid$(e, i, 1)) + 1
                    dic(Mid$(e, i, 1)) = Empty
                End If
            Next
            dic.RemoveAll
        Next
        For Each e In .keys
            If .Item(e) > 1 Then x = Filter(x, e, 0)
        Next
    End With
    UniqDigits = UBound(x) = 0
End Function

[YasserKhalil]

Amazing Jindon. Really wonderful soilution
Thank you very much

[Trebor76]

I see jindon has come up with a superior solution but here's my revised code nonetheless:

Option Explicit
Sub Macro1()

    Dim strNums() As String
    Dim strLineOfNums As String
    Dim i As Long, j As Long, k As Long
    Dim lngCountOfChar As Long, lngLenOfNum As Long
    Dim lngMyRow As Long
    Dim lngUniqueCount As Long
    Dim blnInclude As Boolean
    
    Application.ScreenUpdating = False
    
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        blnInclude = False
        lngUniqueCount = 0
        strLineOfNums = Replace(Range("A" & lngMyRow), "-", "")
        strNums = Split(Range("A" & lngMyRow), "-")
        For i = LBound(strNums) To UBound(strNums)
            lngLenOfNum = Len(strNums(i))
            For j = 1 To lngLenOfNum
                lngCountOfChar = lngCountOfChar + Len(strLineOfNums) - Len(Replace(strLineOfNums, CStr(Mid(strNums(i), j, 1)), ""))
            Next j
            If lngCountOfChar = lngLenOfNum Then
                lngUniqueCount = lngUniqueCount + 1
            End If
            lngCountOfChar = 0
        Next i
        'If the combination of a set of digits from a number is only in the 'strLineOfNums' text once, then...
        If lngUniqueCount = 1 Then
            '...colour rhe cell green (change to suit)
            Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0)
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

[YasserKhalil]

Thank you very much. But the results seem different. For example one set of your results on my side 37-88-23-4-20
There are 37 and 23 only similar so there are three unique ones (that should not be included)
Anyway never mind. And thanks a lot for the great help

[Trebor76]

Hi Yasser,

I know you have a working solution but it bothers me that I can't get it right. Could you let me know how this goes:

Option Explicit
Sub Macro1()

    Dim strNums() As String
    Dim strLineOfNums As String
    Dim i As Long, j As Long
    Dim lngCountOfChar As Long, lngLenOfNum As Long
    Dim lngMyRow As Long
    Dim lngUniqueCount As Long
    
    Application.ScreenUpdating = False
    
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        strNums = Split(Range("A" & lngMyRow), "-")
        For i = LBound(strNums) To UBound(strNums)
            If i = 0 Then
                strLineOfNums = Replace(Range("A" & lngMyRow), strNums(i) & "-", "")
            ElseIf i > 0 And i < UBound(strNums) Then
                strLineOfNums = Replace(Range("A" & lngMyRow), "-" & strNums(i) & "-", "")
            Else
                strLineOfNums = Replace(Range("A" & lngMyRow), "-" & strNums(i), "")
            End If
            strLineOfNums = Replace(strLineOfNums, "-", "")
            lngLenOfNum = Len(strNums(i))
            For j = 1 To lngLenOfNum
                lngCountOfChar = lngCountOfChar + Len(strLineOfNums) - Len(Replace(strLineOfNums, Mid(strNums(i), j, 1), ""))
            Next j
            If lngCountOfChar = 0 Then
                lngUniqueCount = lngUniqueCount + 1
            End If
            lngCountOfChar = 0
        Next i
        'If there's found to be only 1 unique combination of a set of digits from a number, then...
        If lngUniqueCount = 1 Then
            '...colour rhe cell green (change to suit)
            Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0)
        End If
        lngUniqueCount = 0
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Thanks,

Robert

[YasserKhalil]

Thanks a lot. As for a sample test of about 530 sets
The jindon's UDF returns True on 194 and your macro colored 189
And here are some sets that are not colored
45-84-36-12-36
44-87-26-4-26
46-83-29-6-29
49-85-22-18-22
53-85-19-4-19

[Trebor76]

Must be close - try this:

Option Explicit
Sub Macro1()

    Dim strNums() As String
    Dim strLineOfNums As String
    Dim i As Long, j As Long, k As Long
    Dim lngCountOfChar As Long, lngLenOfNum As Long
    Dim lngMyRow As Long
    Dim lngUniqueCount As Long
    
    Application.ScreenUpdating = False
    
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        strNums = Split(Range("A" & lngMyRow), "-")
        For i = LBound(strNums) To UBound(strNums)
            strLineOfNums = ""
            For j = LBound(strNums) To UBound(strNums)
                If j <> i Then
                   strLineOfNums = strLineOfNums & strNums(j)
                End If
            Next j
            lngLenOfNum = Len(strNums(i))
            For k = 1 To lngLenOfNum
                lngCountOfChar = lngCountOfChar + Len(strLineOfNums) - Len(Replace(strLineOfNums, Mid(strNums(i), k, 1), ""))
            Next k
            If lngCountOfChar = 0 Then
                lngUniqueCount = lngUniqueCount + 1
            End If
            lngCountOfChar = 0
        Next i
        'If there's found to be only 1 unique combination of a set of digits from a number, then...
        If lngUniqueCount = 1 Then
            '...colour rhe cell green (change to suit)
            Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0)
        End If
        lngUniqueCount = 0
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

[YasserKhalil]

That's perfect now.. I like this spirit
Thank you for both of you

[Trebor76]

That's perfect now.. I like this spirit

Thanks Yasser. I'm glad I was able to provide an alternative solution that actually worked

Thank you for both of you

You're welcome