Per favore non diciamo che il codice di Tushar Meta (un guru riconosciuto) e' peggiore di quello di Anthony, perche' altrimenti si arrabbia Zeus in cielo; il primo (e non unico) pregio e' la sua velocita': evidentemente usa un algoritmo logico nella risoluzione del problema, mentre io faccio solo uso di forza bruta per testare tutte le possibili
combinazioni a gruppi di 2, di 3, di 4 ... fino a N-1.
Appena ho una settimana libera provo a smontarla per vedere se, passato il mal di testa, ci capisco qualcosa. Se nel frattempo qualcuno ha in mente un algoritmo matematico da adottare e me lo volesse suggerire...
Comunque ho elaborato una versione 1.2 della macro, con un messaggio iniziale piu' esteso e piu' documentativo; ad esempio viene riepilogato il valore che si andra' a cercare, quante operazioni saranno effettuate (in funzione del limite impostato nel codice) , con quali raggruppamenti, e quale percentuale del numero max di
combinazioni che l' elenco potrebbe generare e' coperto da questi
numeri.
Questo messaggio rende evidente come, con un elenco a 26 elementi pubblicato da femario, fermarsi a 2Milioni di
combinazioni e' una inezia riepetto alle 67Milioni di
combinazioni possibili.
E infatti per ottenere un risultato valido bisogna impostare almeno 30M
combinazioni, che consente di calcolare fino a gruppi di 12 elementi... che sul mio pc richiedono pero' 7minuti e mezzo...
E per trovarli "tutti" bisogna impostarne 60M che richiedono 16 minuti.
La nuova macro:
- Codice: Seleziona tutto
Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean
Dim Kappa As Integer, WResult As String, TgVal, LastLev As Long, II As Long, NElem As Integer
Sub CercaComb()
'Rev. 1.2
'
Dim Col2H As Double, Col2K As Double
'
maxCol = 2 '<<< N° max di match
MaxCombin = 100000000 '<<< N° max di combinazioni che saranno testate
'
FlExit = False
If maxCol > Columns.Count Then maxCol = Columns.Count - 3
TgVal = (InputBox("Valore target?"))
TgVal = Val(Replace(TgVal, ",", ".")) 'Gestisce decimale sia "punto" che "virgola"
VArr = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp))
NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Range("B1").Resize(NElem + 1, Columns.Count - 1).Clear
'
LastLev = 3
For I = 1 To NElem - 1
'modificato per calcolare anche il tot delle combinazioni (uso di Col2K e II)
Col2H = Col2H + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
If Col2H <= MaxCombin Then Col2K = Col2H - 1: II = I
If Col2H <= MaxCombin Then Gruppidi = Gruppidi & " " & I
Next I
Rispo = MsgBox("Il valore target e': " & TgVal _
& vbCrLf & "Impostato max combinazioni: " & Round(MaxCombin / 1000000, 1) & " Milioni" _
& vbCrLf & "N° di combinazioni massime che saranno testate: " & Col2K - _
Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
& "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
& "Massimo " & maxCol & " risultati" & vbCrLf _
& "(Corrispondente al " & Int(Col2K / Col2H * 100) & "% delle possibili combinazioni)" & vbCrLf _
& vbCrLf & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
If Rispo = vbCancel Then Exit Sub
sTimer = Timer
'
If TgVal = 0 Then GoTo ZeroVal
'
For LastLev = 1 To II
For J = 0 To NElem
WkArr(J) = "": WkIndex(J) = ""
Next J
Call Recur(1, NElem, 1)
DoEvents
Next LastLev
If FlExit = True Then mexflex = "(stop per limite di colonne massime da riportare)"
ZeroVal:
MsgBox ("Completato in " & Int(Timer - sTimer) & " Secondi" & vbCrLf & "Rilevati " & _
Application.WorksheetFunction.CountIf(Range("1:1"), "x") _
& " match" & vbCrLf & mexflex)
End Sub
Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer
For myI = Iniz To Final
WkArr(myLevel) = VArr(myI, 1)
WkIndex(myLevel) = myI
If myLevel = LastLev Then
aaa = Application.WorksheetFunction.Sum(WkArr())
If Round(Application.WorksheetFunction.Sum(WkArr()), 3) = Round(TgVal, 3) And FlExit = False Then
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "x"
mycol = Cells(1, Columns.Count).End(xlToLeft).Column
If mycol > maxCol Then FlExit = True
For myK = 1 To LastLev
Cells(WkIndex(myK) + 1, mycol) = 1 'WkIndex(myK)
Next myK
End If
Else
Call Recur(myI + 1, NElem, myLevel + 1)
End If
If FlExit = True Then Exit For
Next myI
End Sub
Va inserita in un Modulo vuoto, in quell' ordine; poi si lancera' la Sub CercaComb
Nei relativi esperimenti ho anche verificato che esistono due
combinazioni che producono il risultato cercato (758120,57):
- Codice: Seleziona tutto
15657,86 1 -
106961,31 1 1
24174,52 1 1
9417,45 - 1
81370,04 1 1
5694,47 - 1
18924,05 - -
8193,38 - 1
16931,65 1 -
30157,11 - -
13073,07 - 1
13159,97 1 1
78005,41 - 1
35956,6 - 1
13432,94 - -
15621,7 - -
15199,55 - -
9819,73 1 1
27643,23 - 1
6480,91 1 -
128174,58 1 -
242131,02 1 1
7175,2 - 1
224422,94 - -
17913,81 1 -
95345,17 1 1
Ciao a tutti.