jmenche
08-30-2010, 06:32 AM
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:
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
08-30-2010, 07:22 AM
There's a module in the attached sheet. The formulas are basic. The issue is in the permutations.
Bob Phillips
08-30-2010, 07:55 AM
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
08-30-2010, 08:18 AM
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
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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.