macro per la ricerca di parole

[massimo-nava-postagmail-comPartecipante massimo-nava-postagmail-com Karma: 1 pt]

Buongiorno. non riesco a risolvere il problema che vi elenco: ho un foglio excel composto da piu di mille righe; h inserito un comando macro per far comparire una finestra di dialogo che mi consenta di trovare cio che ho scritto sul foglio appena citato. quando cio che cerco e' composto da pochi elementi tutto funziona alla perfezione ma se solo ci dovessero essere molte parole identiche la macro si interrompe con un errore di runtime. non capisco e non so cosa devo modificare. provo ad allegare il comando:

Private Sub UserForm_Initialize()
Range("b5").Select
End Sub


Private Sub kESC_Click()
Unload Me
End Sub


Private Sub TextBox1_AfterUpdate()
Dim s As String
Dim ur As Long
Dim match As Range
Dim matches As String
Dim fa As String
Application.Goto Reference:="R5C2"


s = TextBox1
If Trim(s) = "" Then Exit Sub
Application.Goto Reference:="R5C2"

With Worksheets("primanota")
ur = .Cells(.Rows.Count, "g").End(xlUp).Row
With .Range("g5:g" & ur)
Set match = .Find(What:=s, After:=Range("g" & ur), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not match Is Nothing Then
Do
'compilo la collezione degli indirizzi di celle trovate
If matches = "" Then fa = match.Address
matches = matches & match.Address & ","
'passo all'eventuale prossima occorrenza
Set match = .FindNext(match)
'continua a cercare fintanto che l'ennesima occorrenza non corrisponde con la prima trovata

Loop While Not match Is Nothing And match.Address <> fa
End If
End With
End With

If matches <> "" Then
matches = Left(matches, Len(matches) - 1)
Range(matches).Select
End If

Unload Me

End Sub

Allegati:

You must be logged in to view attached files.

[massimo-nava-postagmail-comPartecipante massimo-nava-postagmail-com Karma: 1 pt]

si interrompe sul comando "Range(matches).Select"

[LukeRedsPartecipante LukeReds Karma: 14 pts]

ciao,

se hai fino a 44 (circa...) volte il testo cercato il tutto funziona, dal 45esimo in poi no.....prova a mettere da riga 1 5 47 e poi fino a 48  la stessa lettera...nel primo caso ok, nel secondo caso dà errore

Se sostituisci

matches = matches & match.Address & ","     con

matches = matches & Replace(match.Address & ",", "$", "")

funziona "più a lungo", ma se in matches ci sono più  di 254 o 255 caratteri circa il problema si presenta ugualmente

Se puoi ordinare i dati risolvi il problema, fai una selezione unica

[alexps81Moderatore alexps81 Karma: 56 pts]

Ciao a tutti,

la rimozione del carattere "$" dai vari Address è possibile anche direttamente valorizzando a 0 (zero) i parametri opzionali RowAbsolute e ColumnAbsolute:

matches = matches & match.Address(0, 0) & ","

@massimo-nava-postagmail-com come mai hai la necessità di selezionare le celle che contengono una parola simile a quella scritta in TextBox1? Non sarebbe più facile colorare il fondo di quelle celle?

Ad ogni modo se la tua intenzione rimane la selezione, prova questa modifica al tuo codice:

Private Sub TextBox1_AfterUpdate()
    Dim s As String
    Dim ur As Long
    Dim match As Range
    Dim matches As String
    Dim fa As String
    
    Application.Goto Reference:="R5C2"

    s = TextBox1
    If Trim(s) = "" Then Exit Sub
    Application.Goto Reference:="R5C2"

    With Worksheets("primanota")
        ur = .Cells(.Rows.Count, "g").End(xlUp).Row
        With .Range("g5:g" & ur)
            Set match = .Find(What:=s, After:=Range("g" & ur), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not match Is Nothing Then
                fa = match.Address
                Do
                    matches = matches & match.Address(0, 0) & ","
                    'passo all'eventuale prossima occorrenza
                    Set match = .FindNext(match)
                    'continua a cercare fintanto che l'ennesima occorrenza non corrisponde con la prima trovata
                Loop While Not match Is Nothing And match.Address <> fa
            End If
        End With
    End With

    If matches <> "" Then
        matches = Left(matches, Len(matches) - 1)
        Dim rng As Range
        Dim v As Variant

        For Each v In Split(matches, ",")
            If rng Is Nothing Then
                Set rng = Range(v)
            Else
                Set rng = Union(rng, Range(v))
            End If
        Next v
        
        If Not rng Is Nothing Then rng.Select
    End If

    Unload Me
End Sub

P.S. ricordati che il codice va posto trai i TagCode (codice VBA). Questa volta sistemo io.

[massimo-nava-postagmail-comPartecipante massimo-nava-postagmail-com Karma: 1 pt]

grazie infinito. e' proprio quello che cercavo. se fosse stato per me avrei provato sino all'infinito. grazie davvero

[alexps81Moderatore alexps81 Karma: 56 pts]

massimo-nava-postagmail-com ha scritto:

grazie davvero

Prego, però se per caso la selezione ti ritorna un po' lenta a causa di migliaia di celle in cui cercare, allora il metodo migliore è un ciclo su un Array anziché l'utilizzo di Find e FindNext.

[LukeRedsPartecipante LukeReds Karma: 14 pts]

volevo lasciarti pensare un pò.. ok ecco la soluzione, con più di 32k righe va mofdificata la dichiarazione di k

 

`Private Sub TextBox1_AfterUpdate()
Dim s As String, rngtot As Range, ur As Long, match As Range, k as integer
Dim matches(), fa As String
s = TextBox1
If Trim(s) = "" Then Exit Sub
With Worksheets("primanota")
   ur = .Cells(.Rows.Count, "g").End(xlUp).Row
   With .Range("g5:g" & ur)
      Set match = .Find(What:=s, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
      If Not match Is Nothing Then
         fa = match.Address
         k = 1
         Do
            ReDim Preserve matches(1 To k)
            If k = 1 Then Set rngtot = match
            Set rngtot = Application.Union(rngtot, match)
            k = k + 1
            Set match = .FindNext(match)
         Loop While Not match Is Nothing And match.Address <> fa
      End If
   End With
End With
rngtot.Select
Unload Me
End Sub
`

 

[alexps81Moderatore alexps81 Karma: 56 pts]

Be' ma a questo punto non sarebbe meglio creare il Range unito evitando di ridimensionare ogni volta l'Array matches()?

A quel punto farei così:

Private Sub TextBox1_AfterUpdate()
    Dim s As String
    Dim ur As Long
    Dim match As Range
    Dim matches As String
    Dim fa As String
    Dim rng As Range

    Application.Goto Reference:="R5C2"

    s = TextBox1
    If Trim(s) = "" Then Exit Sub
    Application.Goto Reference:="R5C2"

    With Worksheets("primanota")
        ur = .Cells(.Rows.count, "g").End(xlUp).Row
        With .Range("g5:g" & ur)
            Set match = .Find(What:=s, After:=Range("g" & ur), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not match Is Nothing Then
                fa = match.Address
                Do
                    If rng Is Nothing Then
                        Set rng = Range(match.Address(0, 0))
                    Else
                        Set rng = Union(rng, Range(match.Address(0, 0)))
                    End If
                    'passo all'eventuale prossima occorrenza
                    Set match = .FindNext(match)
                    'continua a cercare fintanto che l'ennesima occorrenza non corrisponde con la prima trovata
                Loop While Not match Is Nothing And match.Address <> fa
            End If
        End With
    End With

    If Not rng Is Nothing Then rng.Select
    Unload Me
End Sub

Anche se, come detto, per tante celle in cui cercare, lavorerei su un Array anziché sulle celle. In questo modo guadagno un po' di tempo e non spreco risorse:

Private Sub TextBox1_AfterUpdate()
    Dim ur As Long, i As Long
    Dim s As String, match As String
    Dim arr As Variant
    Dim rng As Range

    s = Trim(TextBox1.Value)
    If Len(s) = 0 Then Exit Sub

    With Worksheets("primanota")
        ur = .Cells(.Rows.count, "G").End(xlUp).Row
        arr = .Range("G5:G" & ur).Value
        For i = LBound(arr, 1) To UBound(arr, 1)
            match = arr(i, 1)
            If InStr(1, match, s, vbTextCompare) > 0 Then
                If rng Is Nothing Then
                    Set rng = Range(.Cells(i + 4, "G").Address(0, 0))
                Else
                    Set rng = Union(rng, Range(.Cells(i + 4, "G").Address(0, 0)))
                End If
            End If
        Next i
    End With
    If Not rng Is Nothing Then rng.Select
    Unload Me
End Sub

L'unica cosa che non mi è chiara è se la ricerca del match deve essere esatta oppure approssimata: 

se cerco CASA, oltre a CASA va bene anche CASALINGA? Lo chiedo perché nel codice di massimo-nava, nel metodo FIND è stato valorizzato il parametro LookAt:=xlPart (corrispondenza non identica).

Infatti nel mio codice faccio una comparazione con la funzione InStr() ma se invece il match deve essere identico allora basta modificare questa riga:

If InStr(1, match, s, vbTextCompare) > 0 Then

'con questa

If match = s Then

[LukeRedsPartecipante LukeReds Karma: 14 pts]

le soluzioni sono varie, non ce n'è una migliore dell'altra... de gustibus, personalmente preferisco sempre i codici più brevi, a parita di chiarezza

[massimo-nava-postagmail-comPartecipante massimo-nava-postagmail-com Karma: 1 pt]

io sono peggio che alle prime armi.... mi sto sforzando ma temo che ce ne vorra tanto ancora di tempo. d'altra parte questo "mondo" mi affascina e faro di tutto per portarmi almeno a livello principiante.

vi ringrazio tutti infinitamente

[LukeRedsPartecipante LukeReds Karma: 14 pts]

piccola modifica, resume preserve era un'istruzione che avevo dimenticao di cancellare, ho poi aggiunto la gestione dell'errore in caso quanto digitato nella textbox non trovi alcua corrispondenza

 

`Private Sub TextBox1_AfterUpdate()
Dim s As String, rngtot As Range, ur As Long, match As Range
Dim matches(), fa As String
s = TextBox1
If Trim(s) = "" Then Exit Sub
With Worksheets("primanota")
   ur = .Cells(.Rows.Count, "g").End(xlUp).Row
   With .Range("g1:g" & ur)
      Set match = .Find(What:=s, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
      If Not match Is Nothing Then
         fa = match.Address
         Do
            If rngtot Is Nothing Then Set rngtot = match
            Set rngtot = Application.Union(rngtot, match)
            Set match = .FindNext(match)
         Loop While Not match Is Nothing And match.Address <> fa
      End If
   End With
End With
On Error Resume Next
rngtot.Select
Unload Me
End Sub`

[massimo-nava-postagmail-comPartecipante massimo-nava-postagmail-com Karma: 1 pt]

grazie ancora di tutto. Davvero. A presto

[Autore]

Articoli