Form ricerca iscritti | Excel e gli applicativi Office

Form ricerca iscritti

Hai un problema con Excel?

Nuova discussione

Form ricerca iscritti
di isy data: 25/05/2014 00:41:44
Ciao

Ho la necessità di filtrare un elenco di circa 5000 nomi
Allego il file d'esempio: Ricerca.xlsm vi chiedo di provarlo
Si accettano consigli..

Thanks
di lepat (utente non iscritto) data: 25/05/2014 08:12:09
mi sembra perfetto, qual'è il problema ?
di isy (utente non iscritto) data: 25/05/2014 08:20:27
Non ho ancora terminato il codice, mi chiedevo se questa parte è corretta.
Potrei ad esempio disabilitare la ricerca con un solo carattere, un suggerimento per rendere più fluido il codice
di lepat (utente non iscritto) data: 25/05/2014 08:25:05
non conosco abbastanza bene i dictionary per darti consigli, per il resto occorre provare su 5000 nomi, in base alla risposta puoi decidere il numero minimo dei caratteri col quale far partire la ricerca
di Textomb data: 25/05/2014 18:34:25
ciao Isy
ti propongo una soluzione che a mio avviso dovrebbe essere più fluido. Allego file Ricerca Textomb
Soprattutto perchè ad ogni carattere non scorre tutto l'elenco ma va a prendere direttamente le celle con le occorrenze trovate.
Inoltre ho abilitato per la textbox1 la limitazione per l'inserimento dei caratteri dalla a alla z. Quindi nella textbox1 non sono accettati i valori numerici...
Prova e dimmi se funziona per un elenco con 5000 righe.
di isy data: 25/05/2014 19:05:21
Ciao Textomb

Il file non opera allo stesso modo, il filtro che hai utilizzato per i caratteri non consente di inserire uno spazio.

Provo a descrivere meglio il ciclo
Il filtro numerico serve per distinguere due differenti persone registrate in questo modo:
Rossi Paolo
Rossi Paolo 1
Rossi Paolo 2

Nel mio codice posso scrivere indifferentemente il nome e il cognome senza rispettarne l'ordine
Se il nome da ricercare è ad esempio Rossi Maria Paola
Devo poter scrivere come ricerca sia Paola Ros.. che Maria Ros.. solo come esempio

Ringrazio anticipatamente

di scossa data: 26/05/2014 16:29:34
Io semplificherei coosì:

nella userform, sostituisci il codice della tua sub TextBox1_Change() con questa riga:

Me.ListBox1.List = MatchTeam(Me.TextBox1.Text)

Nel modulo standard dove hai la tua sub Elenco() - che puoi eliminare - metti la function MatchTeam() sottoriportata.

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

'---------------------------------------------------------------------------------------
' Procedure : MatchTeam
' Author    : scossa
'---------------------------------------------------------------------------------------
'
Function MatchTeam(ByVal sMatch As String) As Variant
  Dim nLR As Long
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    sTeam = aTeam(j, 1)
    If InStr(1, sTeam, sMatch, vbTextCompare) > 0 Then
      dictTeam(sTeam) = dictTeam(sTeam)
    End If
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di scossa (utente non iscritto) data: 26/05/2014 19:37:01
P.S. @isy: AUGURI!

di scossa data: 26/05/2014 20:13:00
cit. lepat: "per il resto occorre provare su 5000 nomi, in base alla risposta puoi decidere il numero minimo dei caratteri col quale far partire la ricerca"

Ho provato con oltre 28.000 righe di nomi e, mentre nella versione originale di isy la risposta è lenta, col codice che ho proposto la risposta, ad ogni tasto è immediata!

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di isy data: 26/05/2014 23:10:53
Grazie degli auguri scossa
Il codice è più rapido

Volevo anche provare in questo modo, senza un preciso ordine di inserimento nome /cognome
Lo scopo è quello di favorire le ricerche con nomi stranieri
Volevo soprattutto poter testare come opera

Segue codice ancora da ottimizzare

Function MatchTeam(ByVal sMatch As String) As Variant
  Dim nLR As Long
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  Dim Stato As Boolean
  
  Set rng = Foglio1.UsedRange.Columns("C")
  Dim sn
  sn = Split(sMatch, " ")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  
  Stato = True
  On Error Resume Next
  For j = 1 To UBound(aTeam)
    sTeam = aTeam(j, 1)
    If InStr(1, sTeam, sn(0), vbTextCompare) > 0 Then
    Else
      Stato = False
    End If
    If InStr(1, sTeam, sn(1), vbTextCompare) > 0 Then
    Else
      Stato = False
    End If
    If InStr(1, sTeam, sn(2), vbTextCompare) > 0 Then
    Else
      Stato = False
    End If
    If Stato = True Then dictTeam(sTeam) = dictTeam(sTeam)
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di scossa data: 26/05/2014 23:22:36
Scusa ma non ho mica capito cosa vorresti ottenere con quella modifica.
Puoi descrivere il comportamento che ti attendi, tasto dopo tasto digitando ad esempio
R
O
B
E
R
T
O

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di isy (utente non iscritto) data: 27/05/2014 00:43:48
Ciao

Si tratta di una mia personale ricerca

Se il nome/cognome completo che compare in elenco è ad esempio "Rossi Maria Paola"
Vorrei che comparisse nell'elenco immettendo come testo di ricerca...

R
Ro
Ros
Rossi
Rossi M
Rossi Ma
Rossi Mar
Rossi Mari
Rossi Maria
Rossi Maria P
Rossi Maria Pa
Rossi Maria Pao
Rossi Maria Paol
Rossi Maria Paola

Vorrei la possibilità di cercarne una parte suddividendo le ricerche di ogni singolo testo come
Paola Ros
Mar Rossi
Paola Ross Maria

Per ogni suddivisione del testo esegue una ricerca e visualizza le corrispondenza in tutti i test validi
se ci fosse in elenco un nominativo che riporti le voci: "Rossi Maria Paola"
Esempio se scrivo Paola Ross Maria (Vero Vero Vero)
Esempio se scrivo Pa Ross Maria (Vero Vero Vero)

Esempio se scrivo Paola XYZ Maria (Vero Falso Vero)
Al primo test falso cerca nella voce successiva dell'elenco

di scossa data: 27/05/2014 08:19:52
Non è che tu abbia chiarito molto, comunque -se ho capito la tua richiesta - il codice sottoriportato elenca le righe solo se le sottostringhe cominciano con i caratteri via via digitati nella textbox.
Quindi digitanto RO verranno elencati i ROssi Xxxx o i Xxxx ... ROberto ..., ma non i cROzza ....

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

'---------------------------------------------------------------------------------------
' Procedure : MatchTeam
' Author    : scossa
' Date      : 25/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Function MatchTeam(ByVal sMatch As String) As Variant
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    sTeam = " " & aTeam(j, 1) 'match solo a inizio parole
    If InStr(1, sTeam, " " & sMatch, vbTextCompare) > 0 Then
      dictTeam(sTeam) = dictTeam(sTeam)
    End If
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di isy data: 27/05/2014 13:08:58
Ciao

Grazie scossa!
Mi son permesso di modificare in parte il codice che hai suggerito
Per poter scrivere il nome/cognome di ricerca senza un'ordine d'inserimento preciso

Function MatchTeam(ByVal sMatch As String) As Variant
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  
  Dim Sn, k, x0, tx
  Dim stato As Boolean
  With CreateObject("scripting.dictionary")
    Sn = Split(sMatch, " ")
    For k = 0 To UBound(Sn)
        x0 = .Item(Sn(k))
    Next
  End With
  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    stato = True
    For Each tx In Sn
      sTeam = " " & aTeam(j, 1) 'match solo a inizio parole
      If InStr(1, sTeam, " " & tx, vbTextCompare) > 0 Then
      Else
        stato = False
      End If
    Next tx
    If stato = True Then dictTeam(sTeam) = dictTeam(sTeam)
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di scossa data: 27/05/2014 13:13:16
Ma scusa il codice l'hia provato?
Già non c'è alcun ordine di inserimento preciso!

Se poi tu vuoi a tutti i costi complicare le cose e usare la variabile stato libero di farlo .....

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di scossa data: 27/05/2014 13:18:17
Aspetta, forse ho capito cosa intendi ....... non considerare la mia precedente osservazione.

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di scossa data: 27/05/2014 13:55:33
Ho dato una ripulita alla tua modifica:
questa parte è del tutto inutile:
With CreateObject("scripting.dictionary")
Sn = Split(sMatch, " ")
For k = 0 To UBound(Sn)
x0 = .Item(Sn(k))
Next
End With

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

'---------------------------------------------------------------------------------------
' Procedure : MatchTeam
' Author    : scossa
' Date      : 25/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Function MatchTeam(ByVal sMatch As String) As Variant
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  
  Dim Sn, k, x0, tx
  Dim stato As Boolean
  
  Sn = Split(sMatch, " ")

  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    stato = True
    For Each tx In Sn
      sTeam = " " & aTeam(j, 1) 'match solo a inizio parole
      If InStr(1, sTeam, " " & tx, vbTextCompare) = 0 Then
        stato = False
      End If
    Next tx
    If stato = True Then dictTeam(sTeam) = dictTeam(sTeam)
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di scossa data: 27/05/2014 19:05:06
Troppa fretta, altra ripulita alle variabili.

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

'---------------------------------------------------------------------------------------
' Procedure : MatchTeam
' Author    : scossa
' Date      : 25/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Function MatchTeam(ByVal sMatch As String) As Variant
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  Dim Sn As Variant
  Dim tx As Variant
  Dim stato As Boolean
  
  Sn = Split(sMatch, " ")

  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    stato = True
    For Each tx In Sn
      sTeam = " " & aTeam(j, 1) 'match solo a inizio parole
      If InStr(1, sTeam, " " & tx, vbTextCompare) = 0 Then
        stato = False
      End If
    Next tx
    If stato = True Then dictTeam(sTeam) = dictTeam(sTeam)
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di scossa data: 27/05/2014 22:27:57
Volendo si può anche aggiungere, subito dopo
stato = False

un bel
Exit For

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

'---------------------------------------------------------------------------------------
' Procedure : MatchTeam
' Author    : scossa
' Date      : 25/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Function MatchTeam(ByVal sMatch As String) As Variant
  Dim dictTeam As Object
  Dim rng As Range
  Dim aTeam As Variant
  Dim j As Long
  Dim sTeam As String
  Dim Sn As Variant
  Dim tx As Variant
  Dim stato As Boolean
  
  Sn = Split(sMatch, " ")

  
  Set rng = Foglio1.UsedRange.Columns("C")
  Set dictTeam = CreateObject("scripting.dictionary")
  
  aTeam = Intersect(rng, rng.Offset(3, 0))
  For j = 1 To UBound(aTeam)
    stato = True
    For Each tx In Sn
      sTeam = " " & aTeam(j, 1) 'match solo a inizio parole
      If InStr(1, sTeam, " " & tx, vbTextCompare) = 0 Then
        stato = False
        Exit For
      End If
    Next tx
    If stato = True Then dictTeam(sTeam) = dictTeam(sTeam)
  Next
  
  MatchTeam = dictTeam.Keys
  
  Set rng = Nothing
  Set dictTeam = Nothing
End Function

di isy data: 27/05/2014 23:02:36
Ottimo, ho visto che hai rimosso il codice superfluo io avevo postato la modifica troppo in fretta.

Ho già provato il codice nell'elenco completo così è perfetto

Thanks!

Vuoi Approfondire?