Ho riciclato quanto facemmo tempo fa per altro utente qui:
viewtopic.php?f=26&t=101779&p=588947#p588947Spostando alcune dichiarazioni e aggiungendo una macro "d'assieme" (la Sub AllComb, vedi piu' avanti) credo si possa ottenere quanto richiesto.
Il codice complessivo:
- Codice: Seleziona tutto
Option Base 0
Dim col(100), r, n, nr As Long, Col2() As Variant, Col22()
Dim myCombList As String, myMembri As String, myGroup As String, myDest As String
Function comb2(K)
'by Anthony47; Variante che lavora con Col2()
col(K) = col(K - 1)
While col(K) < n - r + K
col(K) = col(K) + 1
If K < r Then
comb2 (K + 1)
Else
nr = nr + 1
For I = 1 To r
Col2(nr - 1, I - 1) = col(I)
'Cells(nr, i) = col(i)
Next
End If
Wend
End Function
Sub CombAnth(dummy)
'by Anthony47
Dim combArr(), I As Long, J As Long, curCalc
'Dim myCombList As String, myMembri As String, myGroup As String, myDest As String
'
'myCombList = "J2" '<<< La cella dove comincia l' elenco delle voci da Combinare
'myMembri = "C3" '<<< La cella che contiene il numero di valori da combinare
'myGroup = "C4" '<<< La cella che contiene il numero di elementi per ogni gruppo
'myDest = "A6" '<<< La cella da dove sara' creato l' elenco combinatorio
'
'curCalc = Application.Calculation
Application.Calculation = xlManual
'
If Range(myCombList) <> "" Then
ReDim combArr(1 To 101)
For I = 0 To 100
If Range(myCombList).Offset(0, I) <> "" Then
combArr(I + 1) = Range(myCombList).Offset(0, I).Value
Else
ReDim Preserve combArr(1 To I)
Exit For
End If
Next I
End If
col2h = Evaluate("FACT(" & myMembri & ")/FACT(" & myGroup & ")/FACT(" & myMembri & "-" & myGroup & ")")
ReDim Col2(col2h - 1, Range(myGroup) - 0)
aaaa = UBound(Col2, 1)
'Ih = 1: Iv = 1
Range(myDest).Resize(Rows.Count - Range(myDest).Row - 1, Range(myMembri) + 2).ClearContents '<<<*** Vedi testo
nr = 0
K = 1
r = Range(myGroup)
n = Range(myMembri)
'[g1] = Timer
comb2 (K)
'
If UBound(combArr, 1) < 100 Then
For I = LBound(Col2, 1) To UBound(Col2, 1)
For J = LBound(Col2, 2) To UBound(Col2, 2)
If Not IsEmpty(Col2(I, J)) Then Col2(I, J) = combArr(Col2(I, J))
Next J
Next I
End If
'Range(myDest).Resize(col2h, Range(myGroup)) = Col2
'[g2] = Timer
'ReDim Col2(1, 1)
Application.Calculation = xlCalculationAutomatic
Calculate
End Sub
Sub AllComb()
'by Anthony47
Dim TotH As Long, K As Long
'
myCombList = "J2" '<<< La cella dove comincia l' elenco delle voci da Combinare
myComb = "C2" '<<< La cella che contiene il calcolo delle Combinazioni, vedi nota* myMembri = "C3" '<<< La cella che contiene il numero di valori da combinare
myGroup = "C4" '<<< La cella che contiene il numero di elementi per ogni gruppo
myDest = "A6" '<<< La cella da dove sara' creato l' elenco combinatorio
'
For I = 1 To Range(myMembri)
Range(myGroup) = I
Calculate
TotH = TotH + Range(myComb)
Next I
ReDim Col22(TotH + 1, Range(myMembri))
For I = 1 To Range(myMembri)
Range(myGroup) = I
Call CombAnth(0)
For J = LBound(Col2, 1) To UBound(Col2, 1)
For K = LBound(Col2, 2) To UBound(Col2, 2)
Col22(i22, K) = Col2(J, K)
Next K
i22 = i22 + 1
Next J
Next I
'
Range(myDest).Resize(i22 + 0, Range(myMembri)) = Col22
'
End Sub
Va messo tutto in un unico Modulo del vba.
La macro da eseguire e' la Sub AllComb.
Le righe della Sub AllComb marcate <<< vanno adattate alla tua situazione; la cella indicata come "cella che contiene il calcolo delle Combinazioni, vedi nota*" deve contenere la formula
=COMBINAZIONE(C3;C4)O meglio, i due parametri della funzione COMBINAZIONE devono essere gli stessi associati alle variabili myMembri e myGroup, se myMembri e myGroup sono diversi rispettivamente da "C3" e "C4".
La cella C3 invece contiene la formula
=CONTA.VALORI(J2:AK2)L'intervallo da J2 verso destra contiene infine i simboli da combinare.
I risultati vengono incollati nella posizione dichiarata con la variabile myDest (A6, nell'esempio). Nelle colonne destinate a essere popolate dal risultato e' vietato scrivere altre informazioni, perche' l'area sara' AZZERATA senza preavviso dalla Sub AllComb; questa area e' larga 2 colonne in piu' rispetto al numero di elementi da combinare.
Il tutto come risulta nel file scaricabile qui:
https://www.dropbox.com/s/xkmwvubfngutr ... .xlsb?dl=0Ciao