Solved: How to find the most common numbers?

[alikirca20]

I have 300 number groups and each group has 22 different numbers (from 1 to 80).

I want to find 5 (or more) numbers that occur together the most.
Can I find these numbers by excel, macro, VBA or any program?

(for example, let us suppose that 4-15-23-36-45 are the most common numbers and these numbers are in 8 groups from 300.)

Is it possible , I added my file to explain my question in detail, Thanks.

[Aussiebear]

alikirca20, please do not cross post without also giving us the link to the other forum. For example:

http://www.mrexcel.com/forum/showthread.php?t=383390

[GTO]

and...

http://www.excelforum.com/excel-prog...n-numbers.html

[alikirca20]

thanks for find my same question in other forms, I look up my questions not answers, you have done very big jop. hohohoho

[mdmackillop]

alikirca
Please read this.

[Aussiebear]

From your response here, I am of the opinion that you do not understand the ramifications of cross posting without providing the linkages. Members of forums provide their assistance in a voluntary capacity and as such deserve respect from those who request assistance. By providing the links to the other forums where you have sought an answer, gives the members here an opportunity to stay up to speed with your current position rather than trying to start from the beginning.

If you gain a reputation of being a serial cross poster, there's a real danger of no one ever wanting to assist you in any forum. As you have noticed, members frequent more than one forum, so it doesn't take long for the message to get around.

[mikerickson]

There are 24,040,016 ways that 5 numbers can be chosen from 1-80.
This routine will find which of those 24,040,016 choices are found in more number groups than the others and display the results in a MsgBox.

This takes a long time since 24,040,016 * 346 is a large number.
[VBA]Option Explicit

Dim ChoiceArray() As Boolean

Sub test()
Dim largestNumber As Long, SizeOfGroup As Long
Dim rowSequences() As String

Dim CurrentGroup() As Long, MaxGroup As Variant
Dim currentMatchCount As Long, maxMatchCount As Long

Dim i As Long, pointer As Long, rowNum As Long
Dim Overflow As Boolean

Dim debugVar As Variant

largestNumber = 80
SizeOfGroup = 5

ReDim ChoiceArray(1 To largestNumber)
For i = 1 To SizeOfGroup
ChoiceArray(i) = True
Next i

With ThisWorkbook.Sheets("Sheet1").Range("B:B")
With Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 22)
ReDim rowSequences(1 To .Rows.Count)
For rowNum = 1 To .Rows.Count
rowSequences(rowNum) = Join(.Rows(rowNum).Value)
Next rowNum
End With
End With

ReDim CurrentGroup(1 To SizeOfGroup)
maxMatchCount = 0
debugVar = 0
Do
Rem loop through possibiities
debugVar = debugVar + 1
pointer = 1
For i = 1 To largestNumber
If ChoiceArray(i) Then
CurrentGroup(pointer) = i
pointer = pointer + 1
End If
Next i
currentMatchCount = 0
For rowNum = 1 To UBound(rowSequences)
currentMatchCount = currentMatchCount - CLng(isSubSequence(rowSequences(rowNum), CurrentGroup))
Next rowNum

If maxMatchCount < currentMatchCount Then
maxMatchCount = currentMatchCount
MaxGroup = CurrentGroup
End If
Call nextChoice(Overflow)
Loop Until Overflow

MsgBox maxMatchCount & vbCr & Join(MaxGroup)
End Sub

Function isSubSequence(ByVal Sequence As String, ByRef TestElements As Variant) As Boolean
Dim seqString As String, oneElement As Variant
Const Delimiter As String = " "
isSubSequence = False
seqString = Delimiter & Sequence & Delimiter
For Each oneElement In TestElements
If Not (seqString Like "*" & Delimiter & oneElement & Delimiter & "*") Then Exit Function
Next oneElement
isSubSequence = True
End Function

Sub nextChoice(Optional ByRef Overflow As Boolean)
Dim pointer As Long, backFiller As Long
Dim i As Long

pointer = LBound(ChoiceArray)
Do
If ChoiceArray(pointer) Then ChoiceArray(pointer) = False: Exit Do
pointer = pointer + 1
Loop Until UBound(ChoiceArray) < pointer

pointer = pointer + 1
backFiller = LBound(ChoiceArray) - 1

Do
If ChoiceArray(pointer) Then
ChoiceArray(pointer) = False
backFiller = backFiller + 1
Else
Exit Do
End If
pointer = pointer + 1
Loop Until UBound(ChoiceArray) < pointer

For i = LBound(ChoiceArray) To backFiller
ChoiceArray(i) = True
Next i
If UBound(ChoiceArray) < pointer Then
Overflow = True
Else
ChoiceArray(pointer - 1) = False
ChoiceArray(pointer) = True
End If
End Sub

Function Join(ByVal inputRRay As Variant, Optional Delimiter As String)
Rem Join emulator for Mac
Dim xVal As Variant
If IsEmpty(inputRRay) Then Exit Function
If Delimiter = vbNullString Then Delimiter = " "
For Each xVal In inputRRay
Join = Join & Delimiter & xVal
Next xVal
Join = Mid(Join, Len(Delimiter) + 1)
End Function[/VBA]
If you are running Windows (rather than a Mac) the UDF Join should be removed.