[VBA EXCEL] Controllo delle combinazioni rimanenti date quelle utilizzate

[rossofoco]

Buongiorno a tutti/e,

intanto mi presento...mi chiamo Amedeo e vi ho "utilizzato" molto ultimamente imparando tante cose! Quindi grazie!

Venendo al dunque, vorrei da voi un consiglio. La situazione è la seguente:

Ho un foglio Excel che riporta sulla prima colonna combinazioni di lunghezza diversa (da poter scegliere di volta in volta) delle lettere I,X. Posta ad esempio la lunghezza della "password" pari a 3 avremmo la seguente tabella

A B
1 IIX XII
2 XII XXII
3 III IXX
4 XXX IXI

Io vorrei con un clic, far apparire nella colonna B (per esempio) tutte le combinazioni rimanenti da poter utilizzare.
Il mio codice VB è il seguente:

Sub Ovale1_Click()

Dim arrayChar() As String, arrayPwd() As String, lunghezza As Integer, Codcheck() As String
Dim a As Integer, numeroComb As Integer, varChar As String, pwd As String
Dim c As Integer, n As Integer, i As Integer
Dim break As Integer, break2 As Integer
Dim found As Boolean

numeroComb = 1
lunghezza = 3
varChar = "X,I"

'calcolo n° combinazioni
For i = 1 To lunghezza
numeroComb = numeroComb * 2
Next i

arrayChar = Split(varChar, ",")
Worksheets("Foglio1").Activate
Foglio1.Cells(1, 1).Activate
'calcolo del numero di celle non vuote
n = Application.WorksheetFunction.CountA(Range(Selection, Selection.End(xlDown)).EntireColumn)

ReDim Codcheck(n) As String
ReDim arrayPwd(numeroComb) As String

'ciclo per assegnare i valori dei codici all'array
For i = 0 To n
Codcheck(i) = Foglio1.Cells(i + 2, 1).Value
Next i
break = 0
i = 0
a = 0

For c = 0 To numeroComb
pwd = genera(arrayChar, lunghezza - 1)

For i = 0 To n

If Codcheck(i) = pwd Then

break1 = break1 + 1
Exit For

End If

found = InStr(1, "" & Join(arrayPwd, "") & "", "" & pwd & "") > 0
If found Then
break2 = break2 + 1
End If
Next i

If break1 = 0 Then
If break2 = 0 Then
arrayPwd(a) = pwd
a = a + 1
End If
End If
break1 = 0
break2 = 0
Next c

i = 1
a = 10
For i = 0 To numeroComb
Foglio1.Cells(i + 1, a) = arrayPwd(i)
Next i

End Sub


Private Function genera(arr, num_cifre)
Dim b As Integer, k As Integer, numero As Integer, variabile As String
numero = UBound(arr)
Randomize
For b = 0 To num_cifre
k = Int((2 * Rnd))
variabile = variabile & arr(k)
Next
genera = variabile
End Function

L'unico problema che mi rimane è che non è detto che la funzione generativa dei codici a tre cifre generi effettivamente tutte le possibili combinazioni. Sapete aiutarmi?? Ve ne sarei infinitamente grato!!!

PS.

Sicuramente il codice non è ottimizzato.... :) abbiate pietà ma le mie conoscenze sono abbastanza basic!!! :)

[Daniels118]

Per favore, usa i tag code per formattare il codice.

La domanda non richiedeva di postare tutto, quello di cui hai bisogno è un algoritmo per generare combinazioni con ripetizione, trovi la versione VBA qui:
http://www.hwupgrade.it/forum/showthread.php?t=2084088

[rossofoco]

Ciao Daniels118,


grazie per la risposta!! :) Io però vorrei avere da voi un piccolo aiuto per capire come oltre a generare un array con le combinazioni di lunghezza K dei due elementi N, posso controllare quali di questi elementi non sono già stati utilizzati nella colonna A del mio foglio di lavoro. Questa parte di controllo mi sta risultando difficile da risolvere. Ogni aiuto sarebbe oro per me!!

Grazie mille,
Amedeo

[Daniels118]

Nella forma più semplice basta fare due loop annidati e selezionare dal primo array gli elementi che non trovi nel secondo:
risultato = ""
for i = 0 to ubound(arr1)
trovato = false
for j = 0 to ubound(arr2)
if arr1(i) = arr2(j) then
trovato = true
exit for
end if
next j
if not trovato then
risultato = risultato & " " & arr1(i)
end if
next i

[rossofoco]

Ciao a tutti,

sto utilizzando il codice gentilmente offerto da voi :

Questa la sub principale

Sub Ovale1_Click()

Dim N() As Variant
N = Array("x", "i")
Dim K As Byte
K = 2

Dim Comb As Collection
Set Comb = CombinazioniSemplici(N, K)

Dim i As Integer
For i = 1 To Comb.Count
Cells(i, 5).Value = (Comb(i))
Next i

End Sub

Mentre questa la sub per calcolo delle combinazioni:

Public Function CombinazioniSemplici(arrayElementi() As Variant, dimensioneGruppo As Byte) As Collection

Dim LC As New Collection
If UBound(arrayElementi) = 0 Then
Set CombinazioniSemplici = LC
End If
If dimensioneGruppo = 0 Or dimensioneGruppo > UBound(arrayElementi) Then
Set CombinazioniSemplici = LC
End If

Dim aP() As Integer
ReDim aP(dimensioneGruppo - 1)
Dim i As Integer
For i = 0 To UBound(aP)
aP(i) = i
Next i
Dim j As Integer
Dim C As String
Dim cnt As Integer
Do
C = ""
For i = 0 To UBound(aP)
C = C & arrayElementi(aP(i))
Next i
LC.Add (C)

cnt = 0
For i = UBound(aP) To 0 Step -1
If aP(i) = UBound(arrayElementi) - cnt Then
cnt = cnt + 1
If cnt = UBound(aP) + 1 Then Exit Do
Else
aP(i) = aP(i) + 1
For j = 0 To UBound(aP)
If i < j Then aP(j) = aP(i) + (j - i)
Next
Exit For
End If
Next i
Loop

Set CombinazioniSemplici = LC

End Function

Come ma se K è maggiore di N (numero degli elementi) mi da errore?

E' questa la sub giusta per calcolare le disposizioni con ripetizione di 2 lettere su 7 cifre (2^7) ??

Scusate ma sono un novizio...abbiate pietà!! :)

[Daniels118]

Combinazioni e disposizioni sono due cose diverse, cosa ti serve esattamente?
In entrambi i casi comunque, quelle "semplici" (cioè senza ripetizione) hanno senso solo per K<=N: come potremmo creare una lista di N elementi diversi se i valori degli elementi sono meno di N?

[Daniels118]

Ti propongo due algoritmi in vbs, il primo è più conciso ed elegante, il secondo è più efficiente e va bene anche per valori di K e N molto grandi:
Public Sub disposizioniConRipetizione(alfabeto(), k, disposizioni())
Dim n 'As Integer
Dim ubAlfabeto 'As Integer
Dim ubParola 'As Integer
Dim nDisp 'As Integer
Dim i 'As Integer
Dim j 'As Integer
Dim parola 'As Integer
Dim sParola 'As String
ubAlfabeto = UBound(alfabeto)
n = ubAlfabeto + 1
ubParola = k - 1
nDisp = n ^ k
Redim disposizioni(nDisp - 1)
For i = 0 To nDisp - 1
parola = i
sParola = ""
For j = 0 To ubParola
sParola = alfabeto(parola Mod n) & sParola
parola = parola \ n
Next 'j
disposizioni(i) = sParola
Next 'i
End Sub
Public Sub disposizioniConRipetizione(alfabeto(), k, disposizioni())
Dim n 'As Integer
Dim ubAlfabeto 'As Integer
Dim ubParola 'As Integer
Dim parola() 'As Integer
Dim nDisp 'As Integer
Dim i 'As Integer
Dim j 'As Integer
Dim sParola 'As String
ubAlfabeto = UBound(alfabeto)
n = ubAlfabeto + 1
ubParola = k - 1
nDisp = n ^ k
Redim disposizioni(nDisp - 1)
Redim parola(k) 'Mettiamo un elemento in più di proposito
For i = 0 To nDisp - 1
sParola = ""
For j = ubParola To 0 Step -1
sParola = sParola & alfabeto(parola(j))
Next 'j
disposizioni(i) = sParola
parola(0) = parola(0) + 1
For j = 0 To ubParola
If parola(j) < n Then Exit For
parola(j) = 0
parola(j + 1) = parola(j + 1) + 1
Next 'j
Next 'i
End Sub