Large Array mit benutzerdefinierten Anzahl von Dimensionen

Question

Ich schrieb vor kurzem eine question um Hilfe zu fragen, wie die Anzahl der Vorkommen von jedem einzelnen Paar von Allergien in einer Bevölkerung zu zählen. Die Lösungen, die ich bekam, waren großartig, aber ich muss jetzt Kombinationen von 3+ Allergien betrachten, und alles mit Excel-Tabellen zu tun, wird ewig dauern.

Ich entschied mich, ein VBA-Skript zu schreiben, um dies zu tun, das funktioniert gut für Paare. Es ist auch viel schneller, seit ich zurück gegangen bin und das Format der Quelldaten so geändert habe, dass die zu jedem ExceptionID gehörenden AllergenIDs in einer einzelnen kommagetrennten Zeichenkette gespeichert sind.

Ich bin jetzt auf der Suche nach einem 3D - oder höheren Array, und weil wir nicht wissen, wie viele Dimensionen wir (bis zu 10 oder 15) benötigen, würde ich lieber eine Reihe von vermeiden Case oder verschachtelte If/Then Anweisungen.

Meine Forschung aufgedreht this article, in dem ich entnehmen, daß, was ich frage praktisch unmöglich ist, aber ich wollte darüber OP Aussage bitten, dass

Ich dachte, es wäre möglich, wenn ich zu tun könnte die Redim-Anweisung zur Laufzeit als String konstruieren und den String ausführen, aber das scheint nicht möglich.

Ich hatte im Grunde die gleiche Idee. Der folgende Code erzeugt einen Typ-Mismatch-Fehler, aber gibt es keine Abweichung davon, die funktionieren könnte? Können wir keine anderen Funktionen (wie join) innerhalb von ReDim übergeben?

Sub testroutine() 

Dim x As Integer, y As Integer 'just a counter 
Dim PairCount() As String 
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key 
    Set AllergenRef = CreateObject("Scripting.Dictionary") 

For x = 1 To 20 
    AllergenRef.Add x, (x * 10) + (2^x) 'dummy data for my dictionary 
Next x 

Dim N_tuple As Integer 
N_tuple = 5 'this value would be provided by a user form at runtime 
Dim ArrayDim() As String 
ReDim ArrayDim(1 To N_tuple) 

For x = 1 To N_tuple 

    ArrayDim(x) = "1 to " & AllergenRef.Count 

Next x 

ReDim PairCount(Join(ArrayDim, ",")) 'This is the line that throws an error 

End Sub 

This article macht es klingen wie das, was ich tue, ist möglich in Java, aber ich spreche kein Javaner, so kann ich nicht wirklich sagen, wie ähnlich sich dies ist, was ich zu erreichen versuchen, oder wenn es eine Möglichkeit, diese Methode zu VBA anzuwenden ...

======== UPDATE ============
Hier ist ein Beispiel der Daten I‘ m mit arbeiten (in separaten Spalten, fügte ich Striche für die Klarheit)

ExceptionID - ExcAllergens
035-100380
076 - 100107,100392,100345,100596,100141,100151,100344
200 - 100123,100200
325-100381
354 - 100381,10 355 - 100381,10 360 - 100.586
390 - 100151,100344,100345,100349
441 - 100380,100368
448 - 100021,100181,100345,100200,100344,100295
491-100381
499-100333
503-100333
507 - 100331,100346,100596,100345,100344,100269,100283

Und hier ein Auszug aus der allergen Definitionen Tabelle (allergen Key ist etwas, was ich so einfach hinzugefügt haben kleinere Zahlen, mit denen gearbeitet wird, sind die 6-stelligen Zahlen, die in unserer DB verwendet werden.

)

AllergenKey - AllergenID - AllergenTag
01-100011 - Açai Berry
02-100012 - Essigsäure
03-100013 - Agar Agar
04-100014 - Agave
05-100015 - Alkohol
06-100016 - Piment
07-100017 - Ammoniumbicarbonat
08-100018 - Amylase
09-100019 - Annatto
10-100.020 - Apfel
11-100.021 - Apfel, Raw
12-100.022 - Aprikose
13-100.023 - Arrowroot
14-100.025 - Ascorbic Acid
15-100.027 - Asparagus
16-100.028 - Avocado
17-100029 - Bakterielle Kultur
18-100030 - Backpulver

Hinweis, dass es 6810 Ausnahme Profile bis hin fro m 1 bis 51 separate Allergien (durchschnittlich 4 oder 5) und 451 verschiedene Allergene. Hier ist das Ergebnis meiner Analyse von Allergen-Paaren (btw, wenn ich sage "Allergen" es enthält auch Ernährungsgewohnheiten wie vegetarisch):

Top 10 Paare - Paar Count - allergen 1 - allergen 2
1-245 - Dairy - Gluten
2-232 - Eier - Nüsse
3-190 - Dairy - Eier
4-173 - Gluten - Oats
5-146 - Soy (kann enthalten) - Soy
6-141 - Milchprodukte - Nüsse
7 - 136 - Rindfleisch - Schweinefleisch
8-120 - Molkerei - Soy
9-114 - Sesam (kann enthalten) - Nüsse
10-111 - Vegetarier 1 - Schweinefleisch

Answer 1

Ich würde nicht mit Ihrem mittleren Datensatz über die maximal möglichen Kombinationen‘kümmern. Sie werden nicht in der Lage sein, alle möglichen Kombinationen zu machen. Sie haben viele Kombinationen, die in der Stichprobenpopulation nicht vorkommen. Versuche nicht, sie alle zu berechnen, und zähle dann die Vorkommen.

Stattdessen durcharbeiten Sie Ihre Beispielpopulation und erstellen Sie die Tupel als Dateneinträge auf dem Arbeitsblatt "Array". Ich schlage vor, den 3-stelligen Allergenschlüssel als Identifizierungsnummern zu verwenden und die Zahlen in Tupeln zu kombinieren. Long (für größere Zahlen ist möglicherweise Dezimal erforderlich).

Der Ansatz, den ich vorschlage, besteht darin, die Tupel als Longs zu kombinieren, die später leicht zerlegt werden können. Verwenden Sie dann die Häufigkeitsfunktion, um das Auftreten jeder Tupel-Nummer zu zählen.Wenn es also Allergene mit Schlüsseln gibt: 1, 17, 451 - sie bilden eine zusammengesetzte Länge von 1.017.451 (identisch mit 451, 17, & 1) - stellen wir sicher, dass jedes Tupel die Reihenfolge von der kleinsten zur größten Taste hat. Das maximale Triple ist also 449.450.451 und das kleinste ist 1.002.003. Beachten Sie, dass Sie NIE 3.002.001 haben können, da dies 1.002.003 duplizieren würde.

Das Modul I mit einem Spiel hatte, ist unter: EDIT - für eine bessere Code

Option Explicit 
Option Base 1 

Public Function concID(paramArr() As Variant) As Variant 
' this function takes an array of numbers and arranges the array into 
' one long code number - with order of smallest to largest 
' the code number generated has each individual array entry as a 3-digit component 

    Dim wsf As WorksheetFunction 
    Dim decExp As Integer 
    Dim i As Long, j As Long 
    Dim bigNum As Variant ' may need to cast to Decimal?? 

    Set wsf = WorksheetFunction 

    'may use cDec if necessary here?? 
    For i = 1 To UBound(paramArr) 
     'determine the position of the component by multiplying by a multiple of 10^3 
     decExp = 3 * (UBound(paramArr) - i) 
     bigNum = bigNum + wsf.Small(paramArr, i) * 10^decExp 
    Next i 
    concID = bigNum 

End Function 

Public Sub runAllergen() 

    Dim ws As Worksheet 
    Dim dataRange As Range, tupleRange As Range, uniqueList As Range, freqRange As Range, r As Range 
    Dim i As Long, j As Long, counter As Long 
    Dim dataArray As Variant, arr As Variant, tempholder As Long 
    Dim bigArray(1 To 10^6, 1 To 1) As Variant ' the array which will hold all the generated combinations from the data 
    Dim tuple As Long 

    tuple = 3 
    'this will come in as a user input. 
    Set ws = Sheet1 
    Set dataRange = ws.Range("A2:A10001")  'I have 10k people in my dataset, and this is just the allergen data vector 

    Application.ScreenUpdating = False 'IMPORTANT for efficiency 

    tempholder = 1 'this is the array index which the next combi entry is to be put into bigArray 
    dataArray = dataRange.Value 'write entire worksheet column to internal array for efficiency 
    For i = 1 To UBound(dataArray) 
     'obtain array of allergen values in each data row to obtain tuples from 
     arr = Split(dataArray(i, 1), ",") 
     If UBound(arr) + 1 >= tuple Then 
       'give over the array of row data to make tuples from and write to bigArray 
       'return the next available index of bigArray to store data 
       tempholder = printCombinations(arr, tuple, bigArray(), tempholder) 
     End If 
    Next i 

    Set r = ws.Range("B2") 
    'write entire list of tuples from data population to worksheet for efficiency - MASSIVE performance boost 
    r.Resize(tempholder - 1, 1).Value = bigArray 
    'copy tuple output over to another column to remove duplicates and get unique list 
    Set tupleRange = ws.Range(r, r.End(xlDown)) 
    tupleRange.Copy 
    Set r = ws.Range("D2") 
    r.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

    'remove duplicates from copied tuple output to get a unique list of codes to serve as bins in FREQUENCY function 
    ws.Range(r, r.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo 
    Set uniqueList = ws.Range(r, r.End(xlDown)) 
    Application.CutCopyMode = False 
    'set the frquency output range which is always 1 more row than the bins array 
    Set freqRange = uniqueList.Offset(0, 1).Resize(uniqueList.Rows.Count + 1, 1) 
    'get the frequency of each tuple 
    freqRange.FormulaArray = "=FREQUENCY(R2C" & tupleRange.Column & ":R" & tupleRange.Rows.Count + 1 & _ 
        "C" & tupleRange.Column & _ 
        ",R2C" & uniqueList.Column & ":R" & uniqueList.Rows.Count + 1 & "C" & uniqueList.Column & ")" 

    Application.ScreenUpdating = True 
End Sub 

Public Function printCombinations(pool As Variant, r As Long, printVector As Variant, tempPosition As Long) As Long 

    'this function writes the data row arrays as tuples/combis to the bigArray, 
    'and returns the next available index in bigArray 
    Dim i As Long, j As Long, n As Long 
    Dim tempholder() As Variant 
    Dim idx() As Long 

    ReDim tempholder(1 To r) 
    ReDim idx(1 To r) 

    n = UBound(pool) - LBound(pool) + 1 
    For i = 1 To r 
     idx(i) = i 
    Next i 

    Do 
     For j = 1 To r 
       tempholder(j) = CLng(pool(idx(j) - 1)) 
     Next j 

     'we now have an array of size tuple from the row data, so construct our code number, 
     'and write to the next available index in bigArray 

     printVector(tempPosition, 1) = concID(tempholder) 
     tempPosition = tempPosition + 1 

     ' Locate last non-max index 
     i = r 
     While (idx(i) = n - r + i) 
       i = i - 1 
       If i = 0 Then 
        'the algorithm has ended with the last index exhausted 
        'return the next available index of bigArray 
        printCombinations = tempPosition 
        Exit Function 
       End If 
     Wend 

     idx(i) = idx(i) + 1 
     For j = i + 1 To r 
       idx(j) = idx(i) + j - i 
     Next j 
    Loop 

End Function 

Ersteinrichtung:

Sie könnten copy-paste über auch Ihr Frequenzbereich in Werte usw. ....

Answer 2

auf meinen Kommentar zu erweitern, hier einige modifizierte Code zu verwenden, ein Array von Arrays basierend auf der bereitgestellten N_tuple Variable. Ich habe eine schwierige Zeit ein Szenario vorstellen, wo würde dies nicht für Sie arbeitet:

Sub testroutine() 

Dim x As Integer, y As Integer 'just a counter 
Dim ArrayTemp() As Variant 
Dim PairCount() As Variant 
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key 
    Set AllergenRef = CreateObject("Scripting.Dictionary") 

For x = 1 To 20 
    AllergenRef.Add x, (x * 10) + (2^x) 'dummy data for my dictionary 
Next x 

Dim N_tuple As Integer 
N_tuple = 5 'this value would be provided by a user form at runtime 

'Now that you have your N_tuple, redim your paircount array 
ReDim PairCount(1 To N_tuple) 

'For each N_tuple, create an array and add it to the PairCount array 
'Note that you could easily have a 2-dimensional array for a table of values as ArrayTemp 
For x = 1 To N_tuple 
    ReDim ArrayTemp(1 To AllergenRef.Count) 
    PairCount(x) = ArrayTemp 
Next x 

'Now you have an array of arrays, which can be easily accessed. 
'For example: PairCount(2)(3) 
'Or if the subarrays are 2-dimensional: PairCount(4)(6, 12) 

'This simply loops through the PairCount array and shows the ubound of its subarrays 
For x = 1 To UBound(PairCount) 
    MsgBox UBound(PairCount(x)) 
Next x 

End Sub