Moderatori: Anthony47, Flash30005
CANAPONE ha scritto:Ciao,
le formule purtroppo non sono d'aiuto.
Mi sono fatto prestare un Excel meno datato del mio (uso anch'io Excel 2003) ed ho messo alla prova una macro che ho trovato in rete.
Qui:
http://www.tushar-mehta.com/excel/templ ... mbinations
Si potesse adattare la macro anche al 2003: è veramente ganza.
Saluti da Firenze
Anthony47 ha scritto:Ciao femario72, benvenuto nel forum.
Anche noi italici avevamo fatto qualcosa, prova a guardare questa discussione:
viewtopic.php?f=26&t=94323#p539509
Ciao
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
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
Anthony47 ha scritto:Se nel frattempo qualcuno ha in mente un algoritmo matematico da adottare e me lo volesse suggerire...
Torna a Applicazioni Office Windows
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
confrontare e evidenziare 2 fogli excel Autore: niccia |
Forum: Applicazioni Office Windows Risposte: 7 |
[EXCEL] controllo corrispondenza tra valori con un vincolo Autore: sbs |
Forum: Applicazioni Office Windows Risposte: 9 |
Visitano il forum: Nessuno e 57 ospiti