Sfida di Natale: conteggio delle vocali

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Tra un panettone e l'altro, vi propongo una sfida facile   

Costruite una funzione che accetti una stringa inserita dall'utente e visualizzi il conteggio delle vocali (A, E, I, O, U) presenti nella stringa. La funzione deve tener conto delle vocali accentate della tastiera italiana.

La sfida è aperta a tuttissimi. Verranno apprezzate concisione, efficacia ed efficienza, ma anche originalità della funzione (nel senso della paternità dell'autore, ma nel senso che se utilizza sistemi non convenzionali è meglio).

Buon lavoro! E una birra virtuale al vincitore   

ps e buon proseguimento di festività   

[maxpitPartecipante maxpit Karma: 7 pts]

Ripubblico

Buongiorno a tutti,

se ho ben inteso la richiesta, Vi sottopongo la mia interpretazione dove l'output è stato generato sulla finestra immediata integrato dal numero anche delle altre lettere:

`Public Sub ContaVocali(Optional sStringa As String = "")

    Dim sArr() As Byte
    Dim i As Long
    Dim Idx As Long
    Dim Ris(5) As Long
    
    If Len(sStringa) Then
        sArr() = StrConv(sStringa, vbFromUnicode)
        For i = 0 To UBound(sArr())
            Idx = 0
            Select Case sArr(i)
                Case 65, 97,  224:       Idx = 1   ' A, a, à
                Case 69, 101, 232, 233:  Idx = 2   ' E, e, è, é
                Case 73, 105, 236:       Idx = 3   ' I, i, ì
                Case 79, 111, 242:       Idx = 4   ' O, o, ò
                Case 85, 117, 249:       Idx = 5   ' U, u, ù
            End Select
            Ris(Idx) = Ris(Idx) + 1
        Next i
    End If

    Debug.Print "Vocale 'A' contenute: " & Ris(1)
    Debug.Print "Vocale 'E' contenute: " & Ris(2)
    Debug.Print "Vocale 'I' contenute: " & Ris(3)
    Debug.Print "Vocale 'O' contenute: " & Ris(4)
    Debug.Print "Vocale 'U' contenute: " & Ris(5)
    Debug.Print "Altre  ---   lettere: " & Ris(0)

End Sub
`

A presto

[scossaPartecipante scossa Karma: 37 pts]

edit

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

maxpit ha scritto:

Vi sottopongo la mia interpretazione

Buona idea sfruttare StrConv per avere un array di bytes in modo rapido e indolore!   

[scossaPartecipante scossa Karma: 37 pts]

Ciao,

la mia proposta è una udf che, passata la stringa da esaminare (sWords), restituisce una stringa con il conteggio delle relative vocali contenute, intramezzate da un separatore (opzionale sSep, se omesso sarà CR+LF):

N.B.: aggiunta istruzione sWords = LCase(sWords) per comprendere le maiuscole.

Function uSillabe(ByVal sWords As String, Optional ByVal sSep = vbCrLf) As Variant
  'by scossa
  Dim vVocals As Variant, vVoc As Variant, sMess As String
  Dim nLenWord As Long, nLenDif As Long

  sWords = LCase(sWords)
  nLenWord = Len(sWords)
  vVocals = Array("a", "e", "i", "o", "u", "à", "è", "é", "ì", "ò", "ù")
  For Each vVoc In vVocals
    nLenDif = nLenWord - Len(Replace(sWords, vVoc, ""))
    If nLenDif > 0 Then sMess = sMess & vVoc & ": " & nLenDif & sSep
  Next vVoc
  uSillabe = Left(sMess, Len(sMess) - Len(sSep))
End Function


Sub test()
  Debug.Print uSillabe("proverò a vedere se funziona e, se funzionerà qui, è certo funzionerà anche lì")
End Sub

esempio lato celle:

in A1:: proverò a vedere se funziona e, se funzionerà qui, è certo funzionerà anche lì

in B1:: =uSillabe(A1; " / " ) [risultato: a: 3 / e: 11 / i: 4 / o: 5 / u: 4 / à: 2 / è: 1 / ì: 1 / ò: 1]

in B1:: =uSillabe(A1; "; " ) [risultato: a: 3; e: 11; i: 4; o: 5; u: 4; à: 2; è: 1; ì: 1; ò: 1]

[Aldo ErcoliniPartecipante Aldo Ercolini Karma: 19 pts]

Ecco la mia versione, molto semplice:

Edit: Resa un po' piu' "elegante"

Option Explicit
Dim Vocale() as String

Sub ControllaLettere()
Dim i As Long, x As Long, y As Long, LG As Long, GruppoLettere As String, risultato As String

    GruppoLettere = LCase(InputBox("Digitare le lettere in cui trovare le vocali"))
    
    LG = Len(GruppoLettere)
    Vocale() = splittastringa("aeiouàèéìòù")
    risultato = "Trovate " & vbNewLine
     
    For i = 0 To 10
        y = 0
        
        For x = 1 To LG
            
            If Vocale(i) = Mid(GruppoLettere, x, 1) Then
                y = y + 1
            End If
            
        Next x
        
        If y > 0 Then
            risultato = risultato & y & " " & Vocale(i) & vbNewLine
        End If
    
    Next i
    
    MsgBox risultato
    
End Sub

Function splittastringa(ByVal lettere As String) As Variant
    lettere = StrConv(lettere, vbUnicode)
    splittastringa = Split(Left(lettere, Len(lettere) - 1), vbNullChar)
End Function`

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

La mia proposta si basa sull'utilizzo di una regex, un'espressione regolare.
Qui in due gusti, la prima versione con un oggetto Dictionary (molto flessibile e pulito), la seconda con una Collection (un oggetto più farraginoso, sia per il pittoresco controllo dei duplicati, sia soprattutto perchè a differenza del Dict non si può accedere direttamente alla key dell'oggetto, che pertanto va ficcata nel valore di ogni chiave sottoforma di array chiave,valore).

Versione con Dictionary:

Public Function vwl_counter_with_dict(s As String) As String
Dim re As Object
Dim m As String
Dim d As Object
Dim v As Variant

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[aeiouàèéìòù]"
    re.IgnoreCase = True
    re.Global = True

    Set d = CreateObject("Scripting.Dictionary")

    If re.test(s) Then
        For Each v In re.Execute(s)
            m = CStr(v)
            If d.exists(m) Then d(m) = d(m) + 1 Else d.Add m, 1
        Next
        m = ""
        For Each v In d
            m = m & v & ": " & d(v) & vbNewLine
        Next
        vwl_counter_with_dict = Left(m, Len(m) - 1)
    Else
        vwl_counter_with_dict = "No vowels"
    End If
End Function

Versione con Collection:

Public Function vwl_counter_with_coll(s As String) As String
Dim re As Object
Dim m As String
Dim d As New Collection
Dim v As Variant
Dim i As Long

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[aeiouàèéìòù]"
    re.IgnoreCase = True
    re.Global = True
    
    If re.test(s) Then
        For Each v In re.Execute(s)
            m = CStr(v)
            On Error Resume Next
            d.Add Array(m, 1), m
            i = d(m)
            If Err.Number <> 0 Then d.Remove m: d.Add Array(m, i + 1), m
            Err.Clear
            On Error GoTo 0
        Next
        m = ""
        For Each v In d
            m = m & v(0) & ": " & v(1) & vbNewLine
        Next
        vwl_counter_with_coll = Left(m, Len(m) - 1)
    Else
        vwl_counter_with_coll = "No vowels"
    End If
End Function

[scossaPartecipante scossa Karma: 37 pts]

vecchio frac ha scritto:

La mia proposta si basa sull'utilizzo di una regex, un'espressione regolare.

"Parafrasando" la tua, propongo anche una soluzione con regex ma senza dictionary né collection:

`Public Function uVocali_with_dict(s As String) As Variant
  Dim re As Object, oMatches As Object
  Dim vRet As Variant
  Dim vVocals As Variant, vVoc As Variant

  Set re = CreateObject("VBScript.RegExp")
  vVocals = Array("A", "E", "I", "O", "U", "a", "e", "i", "o", "u", "à", "è", "é", "ì", "ò", "ù")
  re.IgnoreCase = False
  re.Global = True

  For Each vVoc In vVocals
    re.Pattern = vVoc
    If re.test(s) Then
      vRet = vRet & vVoc & ": "
      Set oMatches = re.Execute(s)
      vRet = vRet & oMatches.Count & vbCrLf
    End If
  Next vVoc
  If vRet <> "" Then
    vRet = Left(vRet, Len(vRet) - 1)
  Else
    vRet = CVErr(xlErrNA) ' "no volwes"
  End If
  uVocali_with_dict = vRet
  Set re = Nothing
End Function
`

Un particolare non trascurabile in questo codice, come in quello che ho precedentemente proposto, è che utilizza un solo ciclo For ed il numero delle relative iterazioni è costante e pari al numero di vocali nella matrice vVocals, il che significa che anche su una stringa di un milioni di caratteri eseguirà solo 16 iterazioni volendo distinguere tra maiuscole e minuscole, e solo 11 se non case sensitive.

[maxpitPartecipante maxpit Karma: 7 pts]

Scusa @scossa, non è che qui sotto, nel commento, c'è traccia di bucellato?

vRet = CVErr(xlErrNA) ' "no volwes"

[scossaPartecipante scossa Karma: 37 pts]

maxpit ha scritto:

non è che qui sotto, nel commento, c'è traccia di bucellato?

Sì, ma quello lo ha mangiato Vecchio Frac  , visto che il mio codice è un "rifacimento" del suo, ho voluto mantenere alcune sue "chicche"   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

vRet = CVErr(xlErrNA)

Bè ma scossa è un alieno e dovrei mettere una clausola quando propongo queste sfide... per esempio: "scossa deve proporre soluzioni che non prevedano la lettera "a" nel suo codice"   

Ragazzi, imparate da scossa per favore   

[gianfranco55Partecipante gianfranco55 Karma: 91 pts]

bene 

ragioniamo al contrario

UDF

Public Function vocali(ByVal sTesto As String) As String

Dim lng As Long

vocali = ""

For lng = 1 To Len(sTesto)
If UCase(Mid(sTesto, lng, 1)) _
Like "[QWRTYPSDFGHJKLZXCVBNM0123456789]" Then
vocali = _
vocali & Mid(sTesto, lng, 1)
End If
Next

End Function

formula

=LUNGHEZZA(SOSTITUISCI(A1;" ";""))-LUNGHEZZA(vocali(A1))

ho semplicemente ragionato al contrario

[scossaPartecipante scossa Karma: 37 pts]

gianfranco55 ha scritto:

If UCase(Mid(sTesto, lng, 1)) Like "[QWRTYPSDFGHJKLZXCVBNM0123456789]" Then

Ma così ottieni una stringa priva di vocali  ?!

Forse intendevi

If Not UCase(Mid(sTesto, lng, 1)) Like "[QWRTYPSDFGHJKLZXCVBNM0123456789]" Then

ma comunque ti ritorna una stringa di vocali (e di punteggiature), non il conteggio delle singole vocali come richiesto.

[gianfranco55Partecipante gianfranco55 Karma: 91 pts]

ciao

Ma così ottieni una stringa priva di vocali  ?!

esatto puoi aggiungere quello che vuoi

con lunghezza() conto quante consonanti e numeri ci sono

e il gioco è fatto

elimino gli spazi dalla frase

lunghezza frase - lunghezza consonanti.= vocali con qualsiasi tipo di accento 

la udf (leggermente modificata) è di Gamberini

 basta cambiare le consonanti con le vocali volute e basta un LUNGHEZZA()

o bisogna contare per singola vocale?

[albatros54Moderatore albatros54 Karma: 89 pts]

la mia , se pur semplice ,UDF

Option Explicit
Function TrovaVocali(frase As String)
Dim matches As Object, match As Object
    Dim RegEx As Object, Str As String
    Dim msg As String, v As Integer, inlen As Integer
    Dim h As String, endLen As Integer, Ripetizioni As Integer
    Dim contavocali As String, vocali As String
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Pattern = "[aeiouèòù|AEIOU]"
        .Global = True
    End With
    Str = frase
    Set matches = RegEx.Execute(Str)
    For Each match In matches

        msg = match.Value & msg
        Debug.Print match.Value
    Next match
    For v = 1 To Len(msg) - 1
        inlen = Len(msg)
        h = Left(msg, 1)
        endLen = Len(Replace(msg, h, ""))
        Ripetizioni = inlen - endLen
        contavocali = h & ";" & Ripetizioni
        vocali = h & ";" & Ripetizioni & vbCrLf & vocali
        msg = (Replace(msg, h, ""))
    Next
    MsgBox vocali
End Function

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

<\br>

[D@niloPartecipante D@nilo Karma: 12 pts]

Buongiorno mettiamo anche una formula??

Il testo in A1

 

=MATR.SOMMA.PRODOTTO(--(VAL.NUMERO(CONFRONTA(STRINGA.ESTRAI(A1;RIF.RIGA(1:100);1);{"a"\"à"\"á"\"e"\"è"\"é"\"i"\"ì"\"í"\"o"\"ò"\"ó"\"u"\"ù"\"ú"};0))))

[scossaPartecipante scossa Karma: 37 pts]

gianfranco55 ha scritto:

o bisogna contare per singola vocale?

Io ho capito di sì, ed il codice di V.F. lo conferma.

D@nilo ha scritto:

Buongiorno mettiamo anche una formula??

Il conteggio dovrebbe essere discriminato sulle singole vocali.

[scossaPartecipante scossa Karma: 37 pts]

edit

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

gianfranco55 ha scritto:

o bisogna contare per singola vocale?

Sì era richiesto, ma mi piace l'originalità della proposta di Gianfranco   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

D@nilo ha scritto:

mettiamo anche una formula??

Mettiamola! Ma anche questa non illustra il conteggio delle vocali (come da titolo). Ma, come nel caso di Gianfranco, apprezzo l'originalità della proposta!   

[gianfranco55Partecipante gianfranco55 Karma: 91 pts]

ok 

solo con il 365

`Public Function vocali(ByVal sTesto As String) As String

Dim lng As Long

vocali = ""

For lng = 1 To Len(sTesto)
If UCase(Mid(sTesto, lng, 1)) _
Like "[AEIOUàèéìòù123456789]" Then
vocali = _
vocali & " " & Mid(sTesto, lng, 1)
End If
Next

End Function`

=MATR.TRASPOSTA(LET(C;UNICI(A.COL(DIVIDI.TESTO(vocali(MINUSC(A2));" ";;VERO)));C&" / "&LUNGHEZZA(A2)-LUNGHEZZA(SOSTITUISCI(A2;C;""))))

fregatemi ora🤣

anche se un difetto ce l'ha ma non ve lo dico

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

gianfranco55 ha scritto:

anche se un difetto ce l'ha ma non ve lo dico

 

[scossaPartecipante scossa Karma: 37 pts]

Ciao,

ho eseguito alcuni benchmark delle varie function proposte (uVocali è la uSillabe rinominata):

Ottime le prestazioni del codice proposto da maxpit, mentre il codice di albatros54 cresce in modo esponenziale al raddoppiare della lunghezza del testo.

La sorpresa inaspettata è che raddoppiando ulteriormente il testo, arrivati a 5.168.128 caratteri, il tempo della mia uVocali "crolla" a oltre 3 secondi, mentre quella di maxpit mantiene un incremento lineare (1,3 secondi) come la proposta con regex di V.F. modificata da me (senza dictionary, a dispetto del nome):

Evidentemente la funzione Replace, perlomeno sul mio pc, su testi cosi lunghi pesa più dei 5 milioni di iterazioni del ciclo For.

[gianfranco55Partecipante gianfranco55 Karma: 91 pts]

ciao

avevo il sospetto che voi VBAISTI 

"no gavì e fasine al querto"

secondi  

io ho delle formule matriciali che se attivo il ricalcolo

posso andare a fare la spesa al Tosano prima che finiscano e ancora

ho tempo a farmi il caffè🤣

 

comunque una mini tabella

e si fa tutto con una formula semplice  

ma il vecchio trentino vuole l'UDF.........vbaisti del piffero

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

@scossa 

Ottime le tue statistiche, grazie ... forse ti è sfuggita la proposta di Aldo Ercolini (post #42446) perchè non la vedo.

gianfranco55 ha scritto:

"no gavì e fasine al querto"

piano piano, è solo scossa che è di un altro pianeta (Asgard?), noi mortali ci arrabattiamo come possiamo   

gianfranco55 ha scritto:

ho tempo a farmi il caffè

io voto per la birra però   

 

[Autore]

Articoli