Creating UDF using VBA in excel to find similar values in a row where order does not matter

Question

I am dealing with unlimited new rows of data every day and I need a UDF that would find similar row values regardless of its order. As you can see in the example bellow A9:F9 and A4:F4 has a similar row values marked as SIMILAR ROW 1. You need to look at the overall data within the row to see that it has same values but not in the same order. I’m not familiar with VBA if someone could please help me it would very well be appreciated. I have been searching for this all over the web now.

Formula Example:

=Similarity(Range Of Data from A:F, Row Of Data)

My sheet looks like below image:

Answer 1

Here is a start. It will help you to find which rows are permutations of other rows. Say we start with:

This UDF() will take the contents of a set of cells; sort the data; concatenate the data; and return the result as a single string:

Public Function SortRow(rng As Range) As String
    ReDim ary(1 To rng.Count) As Variant
    Dim CH As String, i As Long
    CH = Chr(2)
    For i = 1 To 6
        ary(i) = rng(i)
    Next i
    Call aSort(ary)
    SortRow = Join(ary, CH)
End Function

Public Sub aSort(ByRef InOut)

    Dim i As Long, J As Long, Low As Long
    Dim Hi As Long, Temp As Variant

    Low = LBound(InOut)
    Hi = UBound(InOut)

    J = (Hi - Low + 1) \ 2
    Do While J > 0
        For i = Low To Hi - J
          If InOut(i) > InOut(i + J) Then
            Temp = InOut(i)
            InOut(i) = InOut(i + J)
            InOut(i + J) = Temp
          End If
        Next i
        For i = Hi - J To Low Step -1
          If InOut(i) > InOut(i + J) Then
            Temp = InOut(i)
            InOut(i) = InOut(i + J)
            InOut(i + J) = Temp
          End If
        Next i
        J = J \ 2
    Loop
End Sub

So in G1 we enter:

=SortRow(A1:F1)

and copy down and in H1 enter:

=IF(COUNTIF($G$1:$G$7,G1)=1,"unique combination","duplicates")

and copy down:

This shows that rows 2 and 6 have data that are duplicated, but in different order.

Starting from this may help you achieve your goal.

Answer 2

pls. try with below code

Sub test()
    Dim data() As String
    Dim i As Long
    Dim dd As Long
    Dim lastrow As Variant
    Dim lastcolumn As Variant
    Dim status As Boolean
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    lastcolumn = Cells(2, Columns.Count).End(xlToLeft).Column
    ReDim data(lastrow - 1, lastcolumn)
    For i = 2 To lastrow
        For j = 1 To lastcolumn
            data(i - 1, j) = Cells(i, j)
        Next j
    Next i
    For i = 1 To lastrow - 1
        Call similarity(data(), i)
    Next i
End Sub


Public Function similarity(rdata() As String, currrow As Long)
    lastrow = UBound(rdata)
    matchcount = 0
    lastcolumn = UBound(rdata, 2)
    For Z = currrow To lastrow - 1
        ReDim test(lastcolumn) As String
        ReDim test1(lastcolumn) As String
        For i = 1 To lastcolumn
            test(i) = rdata(currrow, i)
            test1(i) = rdata(Z + 1, i)
        Next i
        Call sort(test())
        Call sort(test1())
        For i = 1 To lastcolumn
            If test(i) = test1(i) Then
                matchcount = matchcount + 1
            End If
        Next i
        If matchcount = lastcolumn Then
            If Cells(currrow + 1, lastcolumn + 1).Value <> "" Then
                Cells(currrow + 1, lastcolumn + 1).Value = Cells(currrow + 1, lastcolumn + 1).Value & "|" & "Match with " & Z + 2
            Else
                Cells(currrow + 1, lastcolumn + 1).Value = "Match with " & Z + 2
            End If
            If Cells(Z + 2, lastcolumn + 1).Value <> "" Then
                Cells(Z + 2, lastcolumn + 1).Value = Cells(Z + 2, lastcolumn + 1).Value & "|" & "Match with " & currrow + 1
            Else
                Cells(Z + 2, lastcolumn + 1).Value = "Match with " & currrow + 1
            End If
        End If
        matchcount = 0
    Next Z
End Function

Sub sort(list() As String)
    Dim First As Integer, Last As Long
    Dim i As Long, j As Long
    Dim temp As String

    First = LBound(list)
    Last = UBound(list)
    For i = First To Last - 1
        For j = i + 1 To Last
            If list(i) > list(j) Then
                temp = list(j)
                list(j) = list(i)
                list(i) = temp
            End If
        Next j
    Next i
End Sub