Array Help

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,

Quote:

---

Originally Posted by jmenche

...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

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

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.

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,

Quote:

---

Originally Posted by jmenche

Name = Combination of 4 product names

---

Okay, I get the part about unique combinations.

Quote:

---

Originally Posted by jmenche

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.

Quote:

---

Originally Posted by jmenche

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..

Quote:

---

Originally Posted by jmenche

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:

Code:

---

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):

Code:

---

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,

Mark