Zona RegExp - Anagrammi e combinazioni - Caratteri speciali di Replace

Spesso mi è capitato di dover affrontare quesiti sullo sviluppo di combinazioni o permutazioni.
Ho raccolto alcune funzioni scritte da me che sfruttano le espressioni regolari e l'oggetto dictionary per sviluppare anagrammi e combinazioni con ripetizione.
Le propongo non perchè migliori di altre che si possono trovare nel web ma in quanto diciamo particolari. Hanno il merito di mostrare meccanismi e tecniche meno noti legati a quegli oggetti e per questo spero le troverete interessanti.
Nelle funzioni che anagrammano una parola, viene utilizzato il metodo replace delle RegExp con sequenze meno documentate che sono sicuro troverete interessanti.
Nelle funzioni che sviluppano le combinazioni viene utilizzato un ciclo for each su un dizionario che si alimenta all'interno del ciclo stesso, una sorta di ricorsione,
simile la seconda funzione che però utilizza le espressioni regolari.
Il codice è commentato per spiegarne il funzionamento.
In fondo come al solito alcune routine per testare le funzioni.



'la migliore sintetica e veloce
Function Anagramma_RE_cr(Parola As String)
    Dim i, l As Long, a As Long
    Dim s As String
    Dim Dic As New Dictionary
    Dim RE As New RegExp

    a = Len(Parola)
    RE.Global = True
    RE.Pattern = "\w"
    Dic.Add Parola, 0
    If a < 2 Then Exit Function
    Dic.Add VBA.Strings.StrReverse(Parola), 0
   
    For Each i In Dic
      s = RE.Replace(CStr(i), "$`$'$&")
      For l = 0 To a - 2
        Dic.Item(Mid(s, a * l + 1, a)) = 0
      Next
    Next
    Anagramma_RE_cr = Dic.Keys
End Function

Function Anagramma_RE(Parola As String)


    'di Roberto Mensa - Nick r
     'https://sites.google.com/site/e90e50/vbscript/regexp/anagrammi-e-combinazioni 
    'Funzione che anagramma una Parola
    'Utilizza un oggetto Dictionary e le
    'espressioni regolari, in particolare
    'il metodo replace delle RegExp
   
    Dim v, i, l As Long
    Dim s As String
    Dim Dic As Object
    Dim RE As Object
   
    'verifico che la stringa non sia vuota
    If Len(Parola) = 0 Then Exit Function
   
    'setto dictionary e RegExp
    Set Dic = CreateObject("scripting.dictionary")
    Set RE = CreateObject("vbscript.regexp")
   
    'voglio tutti i risultati
    RE.Global = True
   
    'il pattern \w indica un singolo carattere
    'letterale, numerico o trattino basso
    'equivalente a [A-z0-9_] non comprende le
    'lettere accentate
    RE.Pattern = "\w"
   
    'aggiungo Parola al dizionario
    Dic.Add Parola, 0
   
    'la seconda aggiunta di una stringa vuota
    'serve a consentire la reiterazione del primo ciclo
    'for each che in alternativa terminerebbe subito
    Dic.Add "", 0
   
    For Each i In Dic
      'applico la sostituzione
      s = RE.Replace(CStr(i), "$`$'$& ")
     
      'Il pattern "$`$'$1 " sfrutta tre particolari
      'sequenze vediamole:
   
      '"$`" sostituisce il risultato con la parte di
           'stringa sorgente fino al risultato
           'il carattere accento è digitabile con la
           'combinazione Alt+096
        
      '"$'" sostituisce il risultato con la parte di
           'stringa sorgente che segue il risultato
        
      '"$& " sostituisce con il risultato
   
      'passando per es "12345" al primo ciclo
      'quello che avviene nel dettaglio è questo:
      'la ricerca trova "1" -> $`="" $'="2345" $& ="1 "
      'la ricerca trova "2" -> $`="1" $'="345" $& ="2 "
      'la ricerca trova "3" -> $`="12" $'="45" $& ="3 "
      'la ricerca trova "4" -> $`="123" $'="5" $& ="4 "
      'la ricerca trova "5" -> $`="1234" $'="" $& ="5 "
      'il risultato è "23451 13452 12453 12354 12345 "
       
      'divido la stringa per caricare gli
      'anagrammi nel dictionary
      v = Split(s, " ")
      For l = 0 To UBound(v)-2
        s = v(l)
        'carico ricorsivamente il dictionary
        If Dic.Exists(s) = False Then
            Dic.Add s, 0
        End If
      Next
    Next
   
    'tolgo la stringa vuota
    Dic.Remove ""
   
    'recupero il vettore con le chiavi
    Anagramma_RE = Dic.Keys
   
End Function

Function Anagramma_RE2(Parola As String)
    'di Roberto Mensa - Nick r
     'https://sites.google.com/site/e90e50/vbscript/regexp/anagrammi-e-combinazioni 
    'utilizza la funzione generica replace_RE
    'per il resto identica alla precedente
   
    Dim v, i, l As Long
    Dim s As String
    Dim Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
   
    If Len(Parola) = 0 Then Exit Function
    Dic.Add Parola, 0
    Dic.Add "", 0
    For Each i In Dic
        v = Split(replace_RE(CStr(i), _
            "\w", "$`$'$& ", True), " ")
        For l = 0 To UBound(v)
            s = v(l)
            If Dic.Exists(s) = False Then
                Dic.Add s, 0
            End If
        Next
    Next
    Dic.Remove ""
    Anagramma_RE2 = Dic.Keys
End Function

Function replace_RE( _
    Parola As String, _
    sPattern As String, _
    sRepPattern As String, _
    Optional bGlobal As Boolean, _
    Optional bIgnoreCase As Boolean) As String
    'di Roberto Mensa - Nick r
     'https://sites.google.com/site/e90e50/vbscript/regexp/anagrammi-e-combinazioni 
    'funzione generica di sostituzione

    Dim RE As Object
    Set RE = CreateObject("vbscript.regexp")
   
    RE.Global = bGlobal
    RE.IgnoreCase = bIgnoreCase
    RE.Pattern = sPattern
    replace_RE = RE.Replace(Parola, sRepPattern)
End Function

Sub Combina_Dic( _
    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 dic1 As Object
    Dim L1 As Long, L2 As Long, L3 As Long
    Dim S1 As String, S2 As String
    Dim V1 As Variant
   
    '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 sarebbe sufficiente commentare
    'la if nell'ultimo ciclo for
    'per avere come risultato tutte le
    'combinazioni di lunghezza da 1 fino a lS
       
   
    Set dic1 = CreateObject("Scripting.dictionary")
    L1 = Len(sC)
   
    'carico i caratteri di sC sul
    'dictionary e su un vettore
   
    ReDim sArr(1 To L1) As String
   
    For L2 = 1 To L1
        sArr(L2) = Mid(sC, L2, 1)
        dic1.Add sArr(L2), ""
    Next
   
    'la stringa di chiusura
    S2 = String(lS, sArr(L1))
   
    'carico ricorsivamente il dictionary
    'fino alla stringa di chiusura
   
    For Each V1 In dic1
        For L2 = 1 To L1
            S1 = V1 & sArr(L2)
            dic1.Add S1, ""
        Next
        If S1 = S2 Then Exit For
    Next
   
    'recupero solo le stringhe di lunghezza lS
    L2 = 0
    For Each V1 In dic1
        'commentare la if per avere come
        'risultato tutte le combinazioni di
        'lunghezza da 1 fino a lS
        If Len(V1) = lS Then
            StartRng.Offset(L2) = V1
            L2 = L2 + 1
        End If
    Next
   
End Function

Sub Combina_RE( _
    ByVal sC As String, _
    ByVal lS As Long, _
    StartRng As Excel.Range)
    'di Roberto Mensa - Nick r
    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

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 test_Combina_Dic()
    'di Roberto Mensa - Nick r
   
    Dim rng As Excel.Range

    Set rng = Nuovo_Range(ThisWorkbook, "Combina_Dic_Res ")
    Combina_Dic "abcde", 6, rng
End Sub

Sub test_Combina_RE()
    'di Roberto Mensa - Nick r
   
    Dim rng As Excel.Range

    Set rng = Nuovo_Range(ThisWorkbook, "Combina_RE_Res ")
    Combina_RE "abcd", 3, rng
End Sub

Sub test_Anagramma_RE()
    'di Roberto Mensa - Nick r

    Dim v, t
    Dim l As Long, c As Long
    Dim rng As Excel.Range
    Const Parola As String = "roberto"

    'nel caso si voglia solo gli anagrammi di
    'senso compiuto ... decommentare le righe
    'Attenzione!
    'i tempi si allungano notevolmente
   
    'Dim appW As Object
    'Set appW = CreateObject("Word.application")
   
    Set rng = Nuovo_Range(ThisWorkbook, Parola & " ")
   
    v = Anagramma_RE(Parola)
    For Each t In v
        'If appW.CheckSpelling(CStr(t)) Then
            rng.Offset(l, c) = t
            l = l + 1
            If l > Cells.Rows.Count Then
                c = c + 1
            End If
        'End If
    Next
   
End Sub



Comments