Identify reoccurring in any combination of value in multiple columns

Hello zoneone73,

Welcome to the Forum!

You need to explain your logic in more detail. After looking at both workbooks, I am unable to see the patterns you have presented.

unsure of your requirement, but if you are trying to count how often a value occurs, try a countif() with the criteria being what you want to count?

Please have a look at the attached.

I've done a preliminary sort on each row and then used a binary string to pick out the replicated combinations of three members or greater. Hit the go button to run the code.

Code is shown below.

Sub Test()
Dim MyArray()
Dim UniqueArray()
ColumnCount = Cells(1, Columns.Count).End(xlToLeft).Column - 3
For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(N, 4), Cells(N, 3 + ColumnCount)).Copy Destination:=Cells(N, 6 + ColumnCount)
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(N, 6 + ColumnCount), Cells(N, 5 + (2 * ColumnCount))), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(N, 6 + ColumnCount), Cells(N, 5 + (2 * ColumnCount)))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
Next N

For P = 3 To ColumnCount

    ReDim MyArray(Cells(Rows.Count, 1).End(xlUp).Row, 2 ^ ColumnCount)
    For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Counter = 1
        For X = 1 To 2 ^ ColumnCount - 1
            BinaryString = Left(WorksheetFunction.Rept("0", ColumnCount), ColumnCount - Len(WorksheetFunction.Dec2Bin(X))) & WorksheetFunction.Dec2Bin(X)
            If Len(BinaryString) - Len(WorksheetFunction.Substitute(BinaryString, "1", "")) = P Then
                ArrayElement = ""
                For Y = 1 To ColumnCount
                    If Mid(BinaryString, Y, 1) = "1" Then
                        ArrayElement = ArrayElement & Cells(N, 5 + ColumnCount + Y) & "|"
                    End If
                Next Y
                Counter = Counter + 1
                MyArray(N - 1, Counter) = ArrayElement
            End If
        Next X
    Next N
    
    ReDim UniqueArray(2, 0)
    For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        For M = 1 To 2 ^ ColumnCount
            If MyArray(N - 1, M) <> "" Then
                NewCombination = True
                For Z = 1 To UBound(UniqueArray, 2)
                    If MyArray(N - 1, M) = UniqueArray(1, Z) Then
                        NewCombination = False
                        UniqueArray(2, Z) = UniqueArray(2, Z) + 1
                        Exit For
                    End If
                Next Z
                If NewCombination = True Then
                    ReDim Preserve UniqueArray(2, UBound(UniqueArray, 2) + 1)
                    UniqueArray(1, UBound(UniqueArray, 2)) = MyArray(N - 1, M)
                    UniqueArray(2, UBound(UniqueArray, 2)) = 1
                End If
            End If
        Next M
    Next N
    
    StartColumn = Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2).Column
    
    For A = 1 To UBound(UniqueArray, 2)
        If UniqueArray(2, A) > 1 Then
            Cells(Rows.Count, StartColumn).End(xlUp).Offset(1, 0) = UniqueArray(1, A)
            Cells(Rows.Count, StartColumn).End(xlUp).Offset(0, 1) = UniqueArray(2, A)
        End If
    Next A
    
Next P

End Sub