Array Help

[jmenche]

Howdy,

I'm a bit of an array novice and need some advice. The attached spreadsheet is designed to run through every unique combination of 4 products without duplication and calculate a couple of scores. Since there are over 430,000 combinations of products, I cannot put them in a sheet. I need to put the combined name, reach, freq in a new array...sort the array by reach...and then put the top 20 in a sheet.

I also need to run this for combinations of 2, 3, 5, 6, 7 so any tips on how to dynamically do this would be appreciated too. However, this is secondary.

I greatly appreciate any help.

Thanks

:beerchug:

[GTO]

Greetings,


...I need to put the combined name, reach, freq in a new array...sort the array by reach...and then put the top 20 in a sheet...

Hopefully you will get help from someone better versed, as this part was quite beyond me at present. If you have a moment, could you show what the formula(s) would be for just a couple of examples?

Thanks,

Mark

[jmenche]

There's a module in the attached sheet. The formulas are basic. The issue is in the permutations.

[Bob Phillips]

If you can't be bothered to tell us what it does, and what the issues are, I think you cannot really expect us to bother trying to work it out.

[jmenche]

Sorry, I wasn't being snippy. My calculations are as follows.

Name = Combination of 4 product names
Reach = Record count if any product in combination over 3/TTLRecord Count
Freq = First count all products over 3 in a record and then average that number across all records

I'm having problems writing these to a new array.

Thanks

[GTO]

Hi again,


Name = Combination of 4 product names

Okay, I get the part about unique combinations.


Reach = Record count if any product in combination over 3/TTLRecord Count

Sorry, least for me, this is where my mouth hangs agape and drool starts. Quite possibly just the blonde guy, but what this means or what TTLRecord Count is both are eluding me.


Freq = First count all products over 3 in a record and then average that number across all records

Similar, probably just as I was already lost at Reach..



I'm having problems writing these to a new array.


Just as an aside, change all the Integers to Longs. Currently, "x" blows up first, as Integers cap at 32767.

Hope to help,

Mark

[GTO]

Greetings jmenche,

Not sure if you are still working on this, as its been as few days. This seems to be working, though after trying several different methods, and getting a few mystery results, I would certainly suggest at least a couple of (tedious I know) 'manual' comparisons. In short - started to go a bit 'blind' looking at it, so hope it is correct.

Presuming for the moment that returns are correct, this seems to be about as quick as the other methods I tried (a little quicker actually).

In short - while I do not believe the combinations anywhere near 400,000+ (at least with the sample data), the sample data return 66000+ cominations. So I first tried bulding the initial results array as a 65000 row by 3 cols ( * however many sections needed). Using Excels sorting of each section, then appending the top values from each section gets you there, but it seemed rather kludgy.

As we're only returning the top 20 vals, I then tried mixing in Application.LARGE in a descending loop. Alas, I found out that on a weak computer, if the array is large, she falls flat. Evaluate(=MATCH(LARGE... works, but seemed slow.

After finding an example I could (sorta) understand of a heap sort, I ditched the 'helper sheet' and kept everything in arrays. Even on my 'abacus'/barely electric laptop, it seems to run fine.

Well, hopefully you will let us know of the results...

In a Standard Module:


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) (http://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,

Mark