Option Explicit
Sub Combinations_Rank()
Dim _
lCombinations As Long, lColI As Long, _
lColII As Long, lColIII As Long, _
lColIV As Long, lColCount As Long, _
lRowCount As Long, i As Long, _
x As Long, y As Long, _
lLastRow As Long, lLastCol As Long, _
Keys As Variant, wksData As Worksheet, _
aryData As Variant, aryNames As Variant, _
aryOutput As Variant, Index As Variant
'Dim Start As Double: Start = Timer
On Error Resume Next
Set wksData = ThisWorkbook.Worksheets("soup_data")
On Error GoTo 0
If wksData Is Nothing Then Exit Sub
lLastRow = RangeFound(wksData.Cells).Row
lLastCol = RangeFound(wksData.Cells, , , , , xlByColumns).Column
aryData = Evaluate("=--(" & wksData.Name & "!" & _
wksData.Range(wksData.Cells(2, 2), _
wksData.Cells(lLastRow, lLastCol) _
) _
.Address(False, False, Application.ReferenceStyle) & _
">3)" _
)
aryNames = wksData.Range(wksData.Cells(1, 2), wksData.Cells(1, lLastCol)).Value
lColCount = UBound(aryData, 2)
lRowCount = UBound(aryData, 1)
'66045 combinations
lCombinations = Application.Combin(lColCount, 4)
ReDim aryOutput(1 To lCombinations, 1 To 3)
x = 0
For lColI = 1 To lColCount
For lColII = lColI + 1 To lColCount
For lColIII = lColII + 1 To lColCount
For lColIV = lColIII + 1 To lColCount
x = x + 1
aryOutput(x, 1) = aryNames(1, lColI) & "|" & _
aryNames(1, lColII) & "|" & _
aryNames(1, lColIII) & "|" & _
aryNames(1, lColIV)
For i = 1 To lRowCount
If aryData(i, lColI) Or aryData(i, lColII) _
Or aryData(i, lColIII) Or aryData(i, lColIV) Then
aryOutput(x, 2) _
= aryOutput(x, 2) + 1
aryOutput(x, 3) _
= aryOutput(x, 3) _
+ aryData(i, lColI) _
+ aryData(i, lColII) _
+ aryData(i, lColIII) _
+ aryData(i, lColIV)
End If
Next
Next
Next
Next
Next
Keys = aryOutput
Index = HeapSortM(Keys, 2)
ReDim aryData(1 To 20, 1 To 3)
i = 0
For x = UBound(aryOutput, 1) To UBound(aryOutput, 1) - 19 Step -1
i = i + 1
For y = UBound(aryOutput, 2) To LBound(aryOutput, 2) Step -1
aryData(i, y) = aryOutput(Index(x), y)
Next
Next
Set wksData = Worksheets.Add
With wksData.Range("A1")
.Offset(1).Resize(20, 3).Value = aryData
With .Resize(, 3)
.Value = Array("Combination", "Reach", "Frequency")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End With
Set wksData = Nothing
lCombinations = 0: lColI = 0: lColII = 0: lColIII = 0: lColIV = 0: lColCount = 0
lRowCount = 0: i = 0: x = 0: y = 0: lLastRow = 0: lLastCol = 0
Keys = vbNullString: aryData = vbNullString: aryNames = vbNullString
aryOutput = vbNullString: Index = vbNullString
' Debug.Print Timer - Start
' Beep
End Sub
Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
In a Standard Module (I put the heap sort stuff in a seperate module):
Option Explicit
' Adapted From:
'--------------------------------------------------
' Heap sort routine.
' Returns a sorted Index array for the Keys array.
' Author: Christian d'Heureuse (www.source-code.biz)
'--------------------------------------------------
Function HeapSortM(Keys, Col As Long)
Dim Base As Long: Base = LBound(Keys, 1)
Dim n As Long: n = UBound(Keys, 1) - LBound(Keys, 1) + 1
ReDim Index(Base To Base + n - 1) As Long
Dim i As Long, m As Long
For i = 0 To n - 1: Index(Base + i) = Base + i: Next ' fill index array
For i = n \ 2 - 1 To 0 Step -1 ' generate ordered heap
HeapifyM Keys, Col, Index, i, n
Next
For m = n To 2 Step -1
ExchangeM Index, 0, m - 1 ' move highest element to top
HeapifyM Keys, Col, Index, 0, m - 1
Next
HeapSortM = Index
End Function
Private Sub HeapifyM(Keys, Col As Long, Index() As Long, _
ByVal i1 As Long, ByVal n As Long)
' Heap order rule: a[i] >= a[2*i+1] and a[i] >= a[2*i+2]
Dim Base As Long: Base = LBound(Index)
Dim nDiv2 As Long: nDiv2 = n \ 2
Dim i As Long: i = i1
Do While i < nDiv2
Dim k As Long: k = 2 * i + 1
If k + 1 < n Then
If Keys(Index(Base + k), Col) < Keys(Index(Base + k + 1), Col) Then k = k + 1
End If
If Keys(Index(Base + i), Col) >= Keys(Index(Base + k), Col) Then Exit Do
ExchangeM Index, i, k
i = k
Loop
End Sub
Private Sub ExchangeM(a() As Long, ByVal i As Long, ByVal j As Long)
Dim Base As Long: Base = LBound(a)
Dim temp As Long: temp = a(Base + i)
a(Base + i) = a(Base + j)
a(Base + j) = temp
End Sub
Hope that helps,
Reply With Quote
Originally Posted by jmenche
