vba excel: tutte le combinazioni possibili con "x" lettere

[karug64]

Salve a tutti.

Allego il file su cui sto lavorando.

http://www.filedropper.com/parole_1

In colonna "A" ho un elenco di parole (dizionario free scaricato da internet).
In C1 ho la lunghezza della parola da "comporre"
In D1...K1 ho le lettere che posso usare per formare le parole

Sto cercando di realizzare una macro che permutando tutte le possibili combinazioni con le lettere presenti e per la lunghezza data, ricerchi tra le parole di colonna "A" e se trova una corrispondenza la scrive in colonna "N"

Quindi, su un esempio semplice, se le lettere a disposizione fossero 4 (O,A,C,S), e in C1 avessi 3, le possibili soluzioni di colonna N potrebbero essere:
OCA
OSA
...
....

Qualche spunto ?

Grazie

[Marius44]

Ciao
qualche tempo fa misi in ... cassaforte le macro di Roberto Mensa che fanno quello che chiedi. Le ho inserite (Sub e Function) nel file che allego ed ho associato la Sub al pulsante Elabora.
C'è un "piccolo" problema. La macro elabora tutte le combinazioni e le mostra in un nuovo Foglio che crea nella colonna A. Dovrai quindi essere tu a confrontarle col tuo dizionario nella colonna A del tuo Foglio ed eliminare quelle che non combaciano.

Questo il link :https://www.dropbox.com/s/01ezlk10wgt65ux/PAROLE_Bis.xlsm?dl=0

Questo il codice:

Codice: Seleziona tutto

Sub test_Combina_RE()
    'di Roberto Mensa - Nick r
    Dim rng As Excel.Range
    For i = 4 To 11
        lettere = lettere & Cells(1, i)
    Next
    num = Range("C1").Value
    Stop
    Set rng = Nuovo_Range(ThisWorkbook, "Combina_RE_Res ")
    'Combina_RE "TOILACOT", 5, rng
    Combina_RE lettere, num, rng
End Sub
Function Nuovo_Range( _
    Wb As Excel.Workbook, _
    Optional Nome_base As _
    String = "Foglio") As Excel.Range
    'di Roberto Mensa - Nick r
   
    'restituisce la cella A1 di un nuovo foglio
    'il nuovo foglio viene rinominato in base
    'all'argomento Nome_base
   
    Dim b
    Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Do
        Err.Clear
        Nuovo_Range.Parent.Name = Nome_base & b
        b = b + 1
    Loop While Err
    Application.ScreenUpdating = True
End Function
Sub Combina_RE( _
    ByVal sC As String, _
    ByVal lS As Long, _
    StartRng As Excel.Range)
    'di Roberto Mensa - Nick r
     'https://sites.google.com/site/e90e50/vbscript/regexp/anagrammi-e-combinazioni
    Dim RE As Object
    Dim L1 As Long, L2 As Long
    Dim S1 As String, S2 As String, S3 As String
    Dim V1 As Variant, B1 As Boolean
   
    'Combinazioni con ripetizione
    'sC è l'insieme dei caratteri
    'lS è la lunghezza delle stringhe
    'risultati
    'StartRng è la cella da cui partire
    'per scrivere le combinazioni di
    'ogni carattere di sC (anche ripetuto)
    'per una lunghezza di lS caratteri
   
    'volendo ottenere tutte le combinazioni
    'con lunghezza da 1 a lS basta escludere
    'la if interruttore all'interno del loop
   
    Set RE = CreateObject("VBScript.RegExp")
    L1 = Len(sC)
    RE.Global = True
   
    'creo la stringa di partenza
    'con i singoli caratteri delimitati
    'da uno spazio
    RE.Pattern = "\w"
    S1 = RE.Replace(sC, " $&")
   
    'creo la stringa di controllo di
    'fine loop composta da lS caratteri
    'tutti uguali all'ultimo carattere
    'di sC
    S2 = String(lS, Right(sC, 1))
   
    'ciclo aggiungendo ad ogni parola
    '(serie di caratteri delimitati da
    'spazio) ogni carattere di sC
    'al primo for azzero la stringa
    'liberando memoria (utilizzo una
    'variabile boolean come interruttore)
    RE.Pattern = "\w+"
    Do Until S3 = S2
        B1 = True
        For Each V1 In RE.Execute(S1)
            'l'interruttore
            If B1 Then
                S1 = ""
                B1 = False
            End If
            'ciclo di polamento
            For L2 = 1 To L1
                S3 = V1 & Mid(sC, L2, 1)
                S1 = S1 & " " & S3
            Next
        Next
    Loop
   
    'ultimo ciclo per caricare le
    '*parole* nelle celle
    L2 = 0
    For Each V1 In RE.Execute(S1)
        StartRng.Offset(L2) = V1
        L2 = L2 + 1
    Next
End Sub


Ciao,
Mario

[Anthony47]

Hummm... credo che il lavoro sia piu' semplice di come l'ha visto Marius.

Ad esempio questa macro:

Codice: Seleziona tutto

Sub wYN()
Dim wArr, Lett, I As Long, J As Long, lB0 As Long, myPos
Dim wLen As Long, cW As String, myLetts As String, K As String
'
wArr = Range(Range("A1"), Range("A1").End(xlDown)).Value
Lett = Range(Range("D1"), Range("D1").End(xlToRight)).Value
'
wLen = Range("C1").Value
Range(Range("N1"), Range("N1").End(xlDown)).ClearContents                    '***
lB0 = LBound(wArr)
For I = lB0 To UBound(wArr)
If wArr(I, 1) = "alcol" Then Stop
    If Len(wArr(I, 1)) = wLen Then
        K = 0
        myLetts = Join(Application.WorksheetFunction.Index(Lett, 1, 0), "_")
        cW = wArr(I, 1)
        For J = 1 To wLen
            myPos = InStr(1, myLetts, Mid(cW, J, 1), vbTextCompare)
            If myPos = 0 Then
                Exit For
            Else
                myLetts = Replace(myLetts, Mid(cW, J, 1), "", , 1, vbTextCompare)
                K = K + 1
            End If
        Next J
        If K = wLen Then
            Cells(Rows.Count, "N").End(xlUp).Offset(1, 0) = cW
        End If
    End If
DoEvents
Next I
MsgBox ("Completato...")
End Sub

All'inizio il contenuto di colonna N viene cancellato; se non va bene allora eliminare la riga marcata ***

Ciao

[Marius44]

Ciao Anthony
Come ho detto il codice non è mio (magari ...) ma, ovviamente, il tuo è semplice, snello e velocissimo e, per giunta, ti dà il ... netto.

Vorrei però, se possibile, delle spiegazioni:
a) ho dovuto cambiare questa riga di codice Range(Range("N1"), Range("N1").End(xlDown)).ClearContents
con questa (altrimenti non cancella) Range(Range("N1"), Range("N" & Cells(Rows.Count, 14).End(xlUp).Row)).ClearContents

b) perchè questa assegnazione lB0 = LBound(wArr) che a me dà sempre 1

c) perchè questa riga If wArr(I, 1) = "alcol" Then Stop (cosa c'entra l'alcol?)

Grazie e ciao,
Mario

PS anche questa va in ... cassaforte (e prima di quelle altre)

[Anthony47]

Ah ha...
Avevo aggiunto quella riga perche' nelle prove la macro mi inseriva quel risultato (alcol) ma non avrebbe dovuto; quindi mi e' servita per trovare l'inghippo, ma probabilmente avevo bevuto e ho dimenticato di toglierla dal codice ufficiale. Basta cancellare la riga.

Uso lB0 perche' un array assume il lowbound 0 oppure 1 un funzione di impostazioni che non sono certo di governare. Inizialmente la macro usava anche l'array Lett in un ciclo, quindi c'erano due cicli For LBound(WArr) to UBound(WArr) e For LBound(Lett) to Ubound(Lett); quindi il calcolo di un unico lB0 mi evitava il calcolo di due LBound: un risparmio di almeno 0,1 microsec, vuoi mettere...

Quanto alla pulizia di colonna N hai pienamente ragione: visto che i risultati vengono scritti a partire da Riga 2 bisogna usare End(xlUp) per cancellare l'intervallo:

Codice: Seleziona tutto

Range(Range("N1"), Range("N" & Rows.Count).End(xlUp)).ClearContents            '***


O una delle tante varianti, compreso il piu' semplice

Codice: Seleziona tutto

Range("N:N").ClearContents                   '***

La mia macro non e' confrontabile con quella da te pubblicata, perche' ha un diverso approccio: non calcola tutti gli anagrammi delle lettere date ma individua tra le parole date quelle di lunghezza data che possono essere composte con le lettere date.
Grazie del tuo... "collaudo".

Ciao

[Marius44]

@Anthony
Puntuale, preciso, esaustivo. E cosa vorresti di più!?!?

Grazie, Mario

[turbonet]

salve a tutti,
ho provato la macro di Anthony, purtroppo con office 2003 non funziona, e non riesco ha capire il perchè...
qualcuno la puo provare con office 2003... grazie.

[karug64]

Salve. Provate entrambe le macro.

Ora sto cercando di "capire" il listato di quella di Anthony per tentare di imparare qualcosa in più ....
(il prossimo passo, dovrebbe essere quello di trasportare il codice su altro linguaggio, sganciandomi da excel....)

La prima macro proposta, a me tutte le combinazioni possibili (ovviamente anche le impossibili "TTTTA", per esempio, (questo sarebbe rimediabile), ma è normale che ripeta le combinazioni ? (per esempio AAAEE la trovo 4 volte .....).


Grazie ad entrambi per i suggerimenti.
Alla prossima

[Marius44]

Ciao
Spero di non dire stupidaggini e, al caso, perdonatemi.

La macro di Roberto Mensa precisa che esegue una calcolo di "combinazioni con ripetizioni" ed aggiunge anche che scrive "le combinazioni di ogni carattere di sC (anche ripetuto) per una lunghezza di lS caratteri".
Il risultato dell'elaborazione(combinazione di 8 elementi di classe 5) mi dà 32768 righe di cui 24992 "doppioni" per un netto di 7776

Ciao,
Mario

[Anthony47]

Era pendente anche una osservazione di turbonet:

ho provato la macro di Anthony, purtroppo con office 2003 non funziona, e non riesco ha capire il perchè...
qualcuno la puo provare con office 2003... grazie

.
In XL2003 l'unico problema che vedo e' che (partendo dal file pubblicato da karug) il Pulsante non viene attivato (gli ActiveX piu' recenti non sono compatibili con le versioni piu' vecchie); la macro si completa e mi pare dia il risultato giusto.
Tu che anomalia hai riscontrato?

Ciao

ps: c'e' un messaggio di Marius prima di questo

[turbonet]

salve a tutti,
dopo aver fatto delle prove più approfondite, questo e il risultato:
con windows 7 e office2003 la ricerca delle parole termina dopo 1 minuto;
con windows XP e office2003 la ricerca termina dopo 1 ora e 33 minuti;
nella colonna (A) ho inserito 60453 parole;
in C1 ho inserito 3;
invece dalla cella D1 a seguire le lettere A, O, S, C;
alla fine dell'elaborazione ha trovato le parole osa e oca in tutte e due le prove.
domanda?
e possibile velocizzare l'elaborazione con windows XP?
grazie.

[Anthony47]

Usando il file pubblicato da karug, sul mio XL2003 la macro ha impiegato quasi lo stesso tempo richiesto da XL2010 (meno di 1 minuto).
Quindi in prima battuta mi vien da pensare che ci sia un problema di risorse disponibili sul tuo Pc che gira con Win Xp (memoria, Cpu).

Ciao