Большой массив с определенным пользователем числом измерений

Я бы не стал беспокоиться о максимально возможных комбинациях с вашим средним набором данных. Вы не сможете составить все возможные комбинации. У вас будет много комбинаций, которых не будет в выборке. Не пытайтесь вычислить их все, а затем подсчитать количество случаев.

Вместо этого поработайте со своей выборкой и создайте кортежи как записи данных в «массиве» рабочего листа. Я предлагаю использовать трехзначный ключ аллергена в качестве номеров идентификаторов и комбинировать числа в кортежах типа Long (возможно, Decimal может понадобиться для больших чисел).

Подход, который я предлагаю, заключается в объединении кортежей в длинные, которые можно легко разложить позже. Затем используйте функцию частоты, чтобы подсчитать количество вхождений каждого кортежа 'number'. поэтому, если есть аллергены с ключами: 1, 17, 451 - они образуют составную длину из 1 017 451 (идентичную 451, 17 и 1) - мы гарантируем, что любой кортеж имеет принудительный порядок от наименьшего ключа к наибольшему ключу. Таким образом, максимальная тройка - 449 450 451, а наименьшая - 1 002 003. Обратите внимание, что у вас НИКОГДА не может быть 3 002 001, так как это будет дублировать 1 002 003.

Модуль, с которым я играл, находится ниже: EDIT - для лучшего кода

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

Начальная настройка:

Вы также можете скопировать и вставить свой частотный диапазон в значения и т. Д.